R
RCGUA
I have an Access 2003 Form with a listbox that has three columns. I
know that using a list box like this is not ideal if I want to control
the left-right alignment, however, I am using the method from Stephen
Lebans http://www.lebans.com/justicombo.htm
and it seems like it will work great, except that I would like to
control the alignment of more than just the first column. Using
Lebans' code, I cannot figure out how to align each column. Is there
a way to loop through each column? I would like to have the first
column right-aligned, the second (middle) column center-aligned and
the third column right-aligned.
Anybody have any ideas for modifying the code. In the Rowsouce code
below, the True, is used as True / False to set center or left align,
the
know that using a list box like this is not ideal if I want to control
the left-right alignment, however, I am using the method from Stephen
Lebans http://www.lebans.com/justicombo.htm
and it seems like it will work great, except that I would like to
control the alignment of more than just the first column. Using
Lebans' code, I cannot figure out how to align each column. Is there
a way to loop through each column? I would like to have the first
column right-aligned, the second (middle) column center-aligned and
the third column right-aligned.
Anybody have any ideas for modifying the code. In the Rowsouce code
below, the True, is used as True / False to set center or left align,
the
Code:
is the name of the field in the table, List5 is the name of
the listbox, HORTACRAFT is the name of the table.
The listbox has the Rowsource set with this line of code.
SELECT DISTINCTROW JustifyString("frmJustify","List5",[code],0,True)
AS CODENUM, HORTACRAFT.NAME FROM HORTACRAFT;
which calls the Function named "JustifyString" which is below.
=======
Option Compare Database
Option Explicit
'Authors: Stephen Lebans
' Terry Kreft
'Date: Dec 14, 1999
'Copyright: Lebans Holdings (1999) Ltd.
' Terry Kreft
'Use: Center and Right Align data in
' List or Combo control's
'Bugs: Please me know if you find any.
'Contact: [email protected]
Private Type Size
cx As Long
cy As Long
End Type
Private Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
"CreateFontIndirectA" (lplogfont As LOGFONT) As Long
Private Declare Function apiSelectObject Lib "gdi32" _
Alias "SelectObject" (ByVal hDC As Long, ByVal hObject As Long) 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 apiDeleteObject Lib "gdi32" _
Alias "DeleteObject" (ByVal hObject As Long) As Long
Private Declare Function apiGetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, _
lpSize As Size) As Long
' Create an Information Context
Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long
' Close an existing Device Context (or information context)
Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" _
(ByVal hDC As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex
As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
' Constants
Private Const SM_CXVSCROLL = 2
Private Const LOGPIXELSX = 88
'
' 1) We now call the function with an Optional SubForm parameter. This
is
' the name of the SubForm Control. If you used the Wizard to add the
' SubForm to the main Form then the SubForm control has the same name
as
' the SubForm. But this is not always the case. For the benefit of
those
' lurkers out there<bg> we must remember that the SubForm and the
SubForm
' Control are two seperate entities. It's very straightforward, the
' SubForm Control houses the actual SubForm. Sometimes the have the
same
' name, very confusing, or you can name the Control anything you want!
In
' this case for clarity I changed the name of the SubForm Control to
' SFFrmJustify. Ugh..OK that's not too clear but it's late!
'
' So the adjusted SQL statement is now.
' CODENUM: JustifyString("FrmMain","List5",[code],
0,True,"SFfrmJustify")
'
' ***CODE START
Function JustifyString(myform As String, myctl As String, myfield As
Variant, _
col As Integer, RightOrCenter As Integer, Optional Sform As String =
"") As Variant
' March 21, 2000
' Changes RightOrCenter to Integer from Boolean
' -1 = Right. 0 = Center, 1 = Left
' Called from UserDefined Function in Query like:
' SELECT DISTINCTROW JustifyString("frmJustify","list4",_
' [code],0,False) AS CODENUM, HORTACRAFT.NAME FROM HORTACRAFT;
' myform = name of form containing control
' myctl = name of control
' myfield is the actual data field from query we will Justify
' col = column of the control the data is to appear in(0 based index)
' RightOrCenter True = Right. False = Center
Dim UserControl As Control
Dim UserForm As Form
Dim lngWidth As Long
Dim intSize As Integer
Dim strText As String
Dim lngL As Long
Dim strColumnWidths As String
Dim lngColumnWidth As Long
Dim lngScrollBarWidth As Long
Dim lngOneSpace As Long
Dim lngFudge As Long
Dim arrCols() As String
Dim lngRet As Long
' Add your own Error Handling
On Error Resume Next
' Need fudge factor.
' Access allows for a margin in drawing its Controls.
lngFudge = 60
' We need the Control as an Object
' Check and see if use passed SubForm or not
If Len(Sform & vbNullString) > 0 Then
' Set UserForm = Forms(myform).Controls(Sform).Form
Set UserForm = Forms(myform).Controls
Else
Set UserForm = Forms(myform)
End If
' Assign ListBox or Combo to our Control var
Set UserControl = UserForm.Controls.Item(myctl)
With UserControl
If col > Split(arrCols(), .ColumnWidths, ";") Then Exit Function
If col = .ColumnCount - 1 Then
' Add in the width of the scrollbar, which we get in pixels.
' Convert it to twips for use in Access.
lngScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL)
lngScrollBarWidth = lngScrollBarWidth * (1440 / GetTwipsPerPixel
())
End If
lngColumnWidth = Nz(Val(arrCols(col)), 1)
lngColumnWidth = lngColumnWidth - (lngScrollBarWidth + lngFudge)
End With
' Single space character will be used
' to calculate the number of SPACE characters
' we have to add to the Input String to
' achieve Right justification.
strText = " "
' Call Function to determine how many
' Twips in width our String is
lngWidth = StringToTwips(UserControl, strText)
' Check for error
If lngWidth > 0 Then
lngOneSpace = Nz(lngWidth, 0)
' Clear variables for next call
lngWidth = 0
' Convert all variables to type string
Select Case VarType(myfield)
Case 1 To 6, 7
' It's a number(1-6) or 7=date
strText = Str$(myfield)
Case 8
' It's a string..leave alone
strText = myfield
Case Else
' Houston, we have a problem
Call MsgBox("Field type must be Numeric, Date or String",
vbOKOnly)
End Select
'let's trim the string - better safe than sorry :-)
strText = Trim$(strText)
' Call Function to determine how many
' Twips in width our String is
lngWidth = StringToTwips(UserControl, strText)
' Check for error
If lngWidth > 0 Then
' Calculate how many SPACE characters to append
' to our String.
' Are we asking for Right or Center Alignment?
Select Case RightOrCenter
Case -1
' Right
strText = String(Int((lngColumnWidth - lngWidth) /
lngOneSpace), " ") & strText
Case 0
' Center
strText = String((Int((lngColumnWidth - lngWidth) /
lngOneSpace) / 2), " ") & strText _
& String((Int((lngColumnWidth - lngWidth) /
lngOneSpace) / 2), " ")
Case 1
' Left
strText = strText
Case Else
End Select
' Return Original String with embedded Space characters
JustifyString = strText
End If
End If
' Cleanup
Set UserControl = Nothing
Set UserForm = Nothing
End Function
Function Split(ArrayReturn() As String, ByVal StringToSplit As
String, _
SplitAt As String) As Integer
Dim intInstr As Integer
Dim intCount As Integer
Dim strTemp As String
intCount = -1
intInstr = InStr(StringToSplit, SplitAt)
Do While intInstr > 0
intCount = intCount + 1
ReDim Preserve ArrayReturn(0 To intCount)
ArrayReturn(intCount) = Left(StringToSplit, intInstr - 1)
StringToSplit = Mid(StringToSplit, intInstr + 1)
intInstr = InStr(StringToSplit, SplitAt)
Loop
If Len(StringToSplit) > 0 Then
intCount = intCount + 1
ReDim Preserve ArrayReturn(0 To intCount)
ArrayReturn(intCount) = StringToSplit
End If
Split = intCount
End Function
'************* Code End *************
Private Function StringToTwips(ctl As Control, strText As String) As
Long
Dim myfont As LOGFONT
Dim stfSize As Size
Dim lngLength As Long
Dim lngRet As Long
Dim hDC As Long
Dim lngscreenXdpi As Long
Dim fontsize As Long
Dim hfont As Long, prevhfont As Long
' Get Desktop's Device Context
hDC = apiGetDC(0&)
'Get Current Screen Twips per Pixel
lngscreenXdpi = GetTwipsPerPixel()
' Build our LogFont structure.
' This is required to create a font matching
' the font selected into the Control we are passed
' to the main function.
'Copy font stuff from Text Control's property sheet
With myfont
.lfFaceName = ctl.FontName & Chr$(0) 'Terminate with Null
fontsize = ctl.fontsize
.lfWeight = ctl.FontWeight
.lfItalic = ctl.FontItalic
.lfUnderline = ctl.FontUnderline
' Must be a negative figure for height or system will return
' closest match on character cell not glyph
.lfHeight = (fontsize / 72) * -lngscreenXdpi
End With
' Create our Font
hfont = apiCreateFontIndirect(myfont)
' Select our Font into the Device Context
prevhfont = apiSelectObject(hDC, hfont)
' Let's get length and height of output string
lngLength = Len(strText)
lngRet = apiGetTextExtentPoint32(hDC, strText, lngLength, stfSize)
' Select original Font back into DC
hfont = apiSelectObject(hDC, prevhfont)
' Delete Font we created
lngRet = apiDeleteObject(hfont)
' Release the DC
lngRet = apiReleaseDC(0&, hDC)
' Return the length of the String in Twips
StringToTwips = stfSize.cx * (1440 / GetTwipsPerPixel())
End Function
Private Function GetTwipsPerPixel() As Integer
' Determine how many Twips make up 1 Pixel
' based on current screen resolution
Dim lngIC As Long
lngIC = apiCreateIC("DISPLAY", vbNullString, _
vbNullString, vbNullString)
' If the call to CreateIC didn't fail, then get the info.
If lngIC <> 0 Then
GetTwipsPerPixel = GetDeviceCaps(lngIC, LOGPIXELSX)
' Release the information context.
apiDeleteDC lngIC
Else
' Something has gone wrong. Assume a standard value.
GetTwipsPerPixel = 120
End If
End Function