|
|
I have a work order form with a list box. I would like to use the alpha
search that Steven Lebans uses on his site to load the list box with clients
starting with the letter that is selected. I have a label at the top of my
form A to Z. Does anyone know if I can load my list box using that code on a
new work order only. The already created work orders work perfect, when
choosing next record the list box highlights the client name properly. When
a new record is selected I would like the list box to start at the beginning
of the file which would be names beginning with numbers(there's a few of
them), then 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.
Here's the code-
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)
If Len(strTemp) & vbNullString = 0 Then Exit Sub
'Me.TxtChar = strTemp this field was used in Leban's form
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
Me.FilterOn = False
Else
MsgBox "fldLastName = (fldLastName)"
Me.Filter = "Combo143 LIKE " & Chr(34) & strTemp & "*" & Chr(34)
Me.FilterOn = True
End If
DoEvents
End Sub
Private Sub CmdOff_Click()
Me.FilterOn = False
End Sub
He's using a combo box, of course, and I'm using a list box. I've worked
sometime on this and going bats. If anyone is using this in a similar way
I'd sure appreciate some help.
TIA
|
|
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: Stephen[ at ]lebans.com
'
'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)
lngRet = apiSelectObject(hDC, oldfont) ' Cleanup
apiDeleteObject (newfont) ' Delete the Font we created
lngRet = apiReleaseDC(hWnd, hDC) ' Release the handle to the DC
End Function
I was hoping maybe someone out there has used this code to load a listbox.
He actually used it to load a combo box. I know this code from Stephen
Lebans was written in or about 2000 - I'm using Access 2003. Maybe this is a
wrong approach.
Is there a better way to do this?
"JIM" wrote:
[Quoted Text] > I have a work order form with a list box. I would like to use the alpha
> search that Steven Lebans uses on his site to load the list box with clients
> starting with the letter that is selected. I have a label at the top of my
> form A to Z. Does anyone know if I can load my list box using that code on a
> new work order only. The already created work orders work perfect, when
> choosing next record the list box highlights the client name properly. When
> a new record is selected I would like the list box to start at the beginning
> of the file which would be names beginning with numbers(there's a few of
> them), then 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.
> Here's the code-
>
> 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)
> If Len(strTemp) & vbNullString = 0 Then Exit Sub
> 'Me.TxtChar = strTemp this field was used in Leban's form
> 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
> Me.FilterOn = False
> Else
> MsgBox "fldLastName = (fldLastName)"
> Me.Filter = "Combo143 LIKE " & Chr(34) & strTemp & "*" & Chr(34)
> Me.FilterOn = True
> End If
> DoEvents
> End Sub
>
> Private Sub CmdOff_Click()
> Me.FilterOn = False
> End Sub
>
> He's using a combo box, of course, and I'm using a list box. I've worked
> sometime on this and going bats. If anyone is using this in a similar way
> I'd sure appreciate some help.
> TIA
|
|
I'm sorry Stephen Lebans is not using a combo box for this routine but, a
text field. It was late when I posted. The line in my subroutine now reads:
Me.Filter = "[lboCustomer].[CustomerName] LIKE " & Chr(34) & strTemp & "*" &
Chr(34) 'to load list box in alpha sequence
I'm making progress and now get the message "Enter Parameter Value" which
seems to indicate lboCustomer.CustomerName is not defined properly. I've
read so many posts on this my mind in muddled! Anybody out there?
TIA
"JIM" wrote:
[Quoted Text] > 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: Stephen[ at ]lebans.com
> '
> '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)
>
>
> lngRet = apiSelectObject(hDC, oldfont) ' Cleanup
>
> apiDeleteObject (newfont) ' Delete the Font we created
>
> lngRet = apiReleaseDC(hWnd, hDC) ' Release the handle to the DC
>
> End Function
>
> I was hoping maybe someone out there has used this code to load a listbox.
> He actually used it to load a combo box. I know this code from Stephen
|
|
I'll repost-this post is scary!
"JIM" wrote:
[Quoted Text] > I'm sorry Stephen Lebans is not using a combo box for this routine but, a
> text field. It was late when I posted. The line in my subroutine now reads:
> Me.Filter = "[lboCustomer].[CustomerName] LIKE " & Chr(34) & strTemp & "*" &
> Chr(34) 'to load list box in alpha sequence
> I'm making progress and now get the message "Enter Parameter Value" which
> seems to indicate lboCustomer.CustomerName is not defined properly. I've
> read so many posts on this my mind in muddled! Anybody out there?
> TIA
> "JIM" wrote:
>
> > 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: Stephen[ at ]lebans.com
> > '
> > '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)
> >
> >
|
|
If you add an invisible text box named "FirstLetter" or something, you can
set
me!Firstt letter = "A*", ...Me!Firstletter = "Z*" in eaxh of your label.
The list box query would have like Forms!YourForm!FirstLetter as a
criteria.
Then requery the listbox .
I'm pretty sue that the Access Programmers Guide has code for this so now
would be a good time to buy it.
JIM wrote:
[Quoted Text] > 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: Stephen[ at ]lebans.com
> '
> '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)
>
>
> lngRet = apiSelectObject(hDC, oldfont) ' Cleanup
>
> apiDeleteObject (newfont) ' Delete the Font we created
>
> lngRet = apiReleaseDC(hWnd, hDC) ' Release the handle to the DC
>
> End Function
>
> I was hoping maybe someone out there has used this code to load a
> listbox. He actually used it to load a combo box. I know this code
> from Stephen Lebans was written in or about 2000 - I'm using Access
> 2003. Maybe this is a wrong approach.
> Is there a better way to do this?
>
> "JIM" wrote:
>
>> I have a work order form with a list box. I would like to use the
>> alpha search that Steven Lebans uses on his site to load the list
>> box with clients starting with the letter that is selected. I have
>> a label at the top of my form A to Z. Does anyone know if I can
>> load my list box using that code on a new work order only. The
>> already created work orders work perfect, when choosing next record
>> the list box highlights the client name properly. When a new record
>> is selected I would like the list box to start at the beginning of
>> the file which would be names beginning with numbers(there's a few
>> of them), then 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. Here's the code-
>>
>> 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)
>> If Len(strTemp) & vbNullString = 0 Then Exit Sub
>> 'Me.TxtChar = strTemp this field was used in Leban's form
>> 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
>> Me.FilterOn = False
>> Else
>> MsgBox "fldLastName = (fldLastName)"
>> Me.Filter = "Combo143 LIKE " & Chr(34) & strTemp & "*" & Chr(34)
>> Me.FilterOn = True
>> End If
>> DoEvents
>> End Sub
>>
>> Private Sub CmdOff_Click()
>> Me.FilterOn = False
>> End Sub
>>
>> He's using a combo box, of course, and I'm using a list box. I've
>> worked sometime on this and going bats. If anyone is using this in
>> a similar way I'd sure appreciate some help.
>> TIA
|
|
Thanks Mike for your input. I don't have to capture the first letter as
Stephen Lebans' routine does that and I'm sure of that because I defined the
variable globally and put a watch on it in debug mode-it definitely has the
character there.
What I'm trying to do now is requery the list box. Here's my code (it's
changed since my last post):
Private Sub LblAlpha_MouseUp(Button As Integer, Shift As Integer, X As
Single, Y As Single)
Dim strSQL As String
If Len(strTemp) & vbNullString = 0 Then
MsgBox "You got to FilterOn = False"
Me.FilterOn = False
Else
MsgBox "strTemp = " & strTemp
strSQL = "SELECT DISTINCTROW tblCustomer.CustomerName,
tblCustomer.BillingAddress1, FROM tblCustomer WHERE
((tblCustomer.CustomerName) LIKE '" & strTemp & "*') ORDER BY
tlbCustomer.CustomerName"
Me!lboCustomer.RowSource = strSQL
Me!lboCustomer.Requery
Me!lboCustomer.SetFocus
End If
DoEvents
End Sub
Do you see anything wrong with my SQL? It seems to do everything except
requery the list box.
Many thanks.
"Mike Painter" wrote:
[Quoted Text] > If you add an invisible text box named "FirstLetter" or something, you can
> set
> me!Firstt letter = "A*", ...Me!Firstletter = "Z*" in eaxh of your label.
> The list box query would have like Forms!YourForm!FirstLetter as a
> criteria.
> Then requery the listbox .
>
> I'm pretty sue that the Access Programmers Guide has code for this so now
> would be a good time to buy it.
>
> JIM wrote:
> > 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: Stephen[ at ]lebans.com
> > '
> > '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)
|
|
|