Hi, I would like to use the alpha search that Steven Lebans uses on his site
to load a list box with clients starting with the letter that is selected. I
have a label at the top of my form A to Z. when user clicks on "A" in the
label or "B" the list box would
start at top with the names that begin with the selected alpha character.
On the previous post I forgot to include the module I'm using. It seems to
be working up to a point -running under debug mode all the variables seem to
carry over. The filter is turned on but the commands don't load the listbox
as desired. I just don't know if I can use this for a listbox. Anyway here's
my updated code:
Option Compare Database
Option Explicit
Dim strTemp As String
Private Sub LblAlpha_MouseDown(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Dim StartX As Long, WidthX As Long
strTemp = fAlpha(X, Me.LblAlpha, Me, Me.Box9, StartX, WidthX)
MsgBox "You got to Mousedown"
If Len(strTemp) & vbNullString = 0 Then Exit Sub
'Me.TxtChar = strTemp this field was used in Leban's form
commented out
Me.Box9.Width = WidthX
Me.Box9.Left = Me.LblAlpha.Left + StartX
End Sub
Private Sub LblAlpha_MouseMove(Button As Integer, Shift As Integer, X As
Single, Y As Single)
If Button = vbKeyLButton Then
Call LblAlpha_MouseDown(Button, Shift, X, Y)
End If
DoEvents
End Sub
Private Sub LblAlpha_MouseUp(Button As Integer, Shift As Integer, X As
Single, Y As Single)
If Len(strTemp) & vbNullString = 0 Then
MsgBox "You got to FilterOn = False"
Me.FilterOn = False
Else
MsgBox "strTemp = " & strTemp
Me.Filter = "lboCustomer LIKE " & Chr(34) & strTemp & "*" & Chr(34) 'to
load list box
Me.FilterOn = True
End If
DoEvents
End Sub
And here's the Module my code calls:
Option Compare Database
Option Explicit
Private Type Size
cx As Long
cy As Long
End Type
' Declare API functions
Private Declare Function apiCreateFont Lib "gdi32" Alias "CreateFontA" _
(ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, _
ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, _
ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, _
ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function apiSelectObject Lib "gdi32" Alias "SelectObject"
(ByVal hDC As Long, _
ByVal hObject As Long) As Long
Private Declare Function apiDeleteObject Lib "gdi32" _
Alias "DeleteObject" (ByVal hObject As Long) As Long
Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function apiMulDiv Lib "kernel32" Alias "MulDiv" (ByVal
nNumber As Long, _
ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function apiGetDC Lib "user32" _
Alias "GetDC" (ByVal hWnd As Long) As Long
Private Declare Function apiReleaseDC Lib "user32" _
Alias "ReleaseDC" (ByVal hWnd As Long, _
ByVal hDC As Long) As Long
Private Declare Function apiDeleteDC Lib "gdi32" _
Alias "DeleteDC" (ByVal hDC As Long) As Long
Private Declare Function GetTextExtentPoint32 _
Lib "gdi32" Alias "GetTextExtentPoint32A" _
(ByVal hDC As Long, ByVal lpsz As String, _
ByVal cbString As Long, lpSize As Size) As Long
' CONSTANTS
Private Const TWIPSPERINCH = 1440
' Used to ask System for the Logical pixels/inch in Y axis
Private Const LOGPIXELSY = 90
Public Function fAlpha(ByVal CurX As Single, ctl As Control, frm As
Access.Form, _
Optional ctlFrame As Control, Optional FrameStartX As Long = -1, _
Optional FrameWidth As Long = -1) As String
'Name FUNCTION() fAlpha
'
'Purpose: A Label control is filled with all of the
' Capital letters of the Alphabet with a space between
each letter.
' The user clicks with the Left Mouse Button
' directly over the character they want to select.
'
'Calls: Text API stuff. DrawText performs the actual
' calculation to determine string Width
'Returns: The letter of the alphabet the Mouse was
' over when the LMB was clicked.
'
'Created by: Stephen Lebans
'
'Credits: Original Concept by Lyle Fairfield.
'Feedback: (e-mail address removed)
'
'My Web Page:
www.lebans.com
'
'Copyright: Lebans Holdings Ltd.
' Please feel free to use this code
' without restriction in any application you develop.
' This code may not be resold by itself or as
' part of a collection.
'Stephen Lebans
'***************Code Start***************
If IsNull(ctl.FontSize) Then Exit Function ' Did we get a valid control
passed to us?
Dim sz As Size ' Structure for GetTextextentPoint32
Dim hWnd As Long ' Handle to Report's window
Dim hDC As Long ' Reports Device Context
Dim lngYdpi As Long ' Holds the current screen resolution
Dim newfont As Long ' Handle to our Font Object we created.
' We must destroy it before exiting main function
Dim oldfont As Long ' Device Context's Font we must Select back into the DC
' before we exit this function.
Dim lngRet As Long ' Temporary holder for returns from API calls
Dim fheight As Long ' Calculate screen Font height
Dim lngWidth As Long ' Width of Substring
Dim lngPreviousWidth As Long ' Previous width of Subtring
Dim strSelect As String ' Hold our Label's string
strSelect = " A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "
Dim strTemp As String ' Temp string var
Dim ctr As Long ' Loop counter
hWnd = frm.hWnd ' Get Forms window
hDC = apiGetDC(hWnd) ' retrieve a handle to a display device context (DC)
' for the client area of the specified window
Dim arrayCharWidth(1 To 53) As Long ' Array to hold width of each character
Dim arrayStringWidth(1 To 53) As Long ' Array to hold width of each
substring(a ,a b, a b c, etc.)
' Because Access control's do not have a permanent Device Context,
' we cannot depend on what we find selected into the DC unless
' the Control has the focus. In this case we are simply using the
' Control's Font attributes to build our own font in whatever
' DC is handy. We must Save this DC's Font so we can restore
' the Font when we exit this function.
lngRet = 0 ' Clear our return value
Dim lngIC As Long ' Temporary Information Context for Screen info.
' Modified to allow for different screen resolutions
' and printer output. Needed to Calculate Font size
lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
If lngIC <> 0 Then
lngYdpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
apiDeleteDC (lngIC)
Else
lngYdpi = 120 'Default average value
End If
fheight = apiMulDiv(ctl.FontSize, lngYdpi, 72) ' Calculate/Convert requested
Font Height
' into Font's Device Coordinate space
' We use a negative value to signify
' to the CreateFont function that we want a Glyph
' outline of this size not a bounding box.
With ctl
newfont = apiCreateFont(-fheight, 0, _
0, 0, .FontWeight, _
.FontItalic, .FontUnderline, _
0, 0, 0, _
0, 0, 0, .FontName)
End With
oldfont = apiSelectObject(hDC, newfont) ' Select the new font into our DC.
If CurX <= 0 Then CurX = 1 ' Convert MouseDown TWIPS value to Pixels
CurX = (CurX / TWIPSPERINCH) * lngYdpi
' Use DrawText to Calculate width of the of Rectangle required to hold
' the current contents of the string passed to this function.
' Init counters
lngWidth = 0
ctr = 0
Do While lngWidth < CurX
ctr = ctr + 1
If ctr > Len(strSelect) Then
fAlpha = ""
Exit Function
End If
strTemp = Left(strSelect, ctr) ' Grab the next char and add it to our
current string
lngPreviousWidth = lngWidth ' Store previous width of string
lngRet = GetTextExtentPoint32(hDC, strTemp, Len(strTemp), sz) 'Find
width of string
lngWidth = sz.cx ' Copy string width to our loop comparison var
'Debug.Print "Width:" & lngWidth
'Debug.Print "PrvWidth:" & lngPreviousWidth
'Debug.Print ""
arrayCharWidth(ctr) = lngWidth - lngPreviousWidth
arrayStringWidth(ctr) = lngWidth
Loop
fAlpha = Mid(strSelect, ctr, 1) ' Return the character selected
If fAlpha = " " Then ' If we are at the very first char, a SPACE char,
' then we need to exit
If ctr = 1 Then
fAlpha = ""
Exit Function
End If
fAlpha = Mid(strSelect, ctr - 1, 1) ' It's a SPACE so back up one
character
FrameWidth = arrayCharWidth(ctr - 1)
FrameStartX = arrayStringWidth(ctr - 1) - FrameWidth
Else
FrameWidth = arrayCharWidth(ctr)
FrameStartX = arrayStringWidth(ctr) - FrameWidth
End If
' We'll subtract 2 pixels from the starting point and
' add 1/2 the width of a SPACE char to the ending point to achive a cleaner
look.
' Plus we have to add 2 pixels to the starting point allow for the
' Left hand margin Access allows before text output.
' *** Because the Text extent values are not 100% accurate
' you will have to play around with these values a bit.
' In order to achieve 100% accuracy you have to scale
' the selected font up to its design dimnesions, around 2000 x 2000
' and then call one of the GetCharacterWidthFloat API's.
' Too much to bother with for this function.
FrameWidth = FrameWidth + arrayCharWidth(1)
FrameStartX = (FrameStartX - (arrayCharWidth(1) / 2)) + 2
' Now convert return values to TWIPS
FrameWidth = FrameWidth * (TWIPSPERINCH / lngYdpi)
FrameStartX = FrameStartX * (TWIPSPERINCH / lngYdpi)
