How to use Screen.Fonts Collection in VBA? [Archive]

CyberLynx

07-28-2008, 02:23 AM

I'm not even gonna ask why.

You can do this by using Windows API functions.

Open a new Database Code Module and name it EnumFontsModule (or whatever you want). Place this Code into that module:

Option Explicit

Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4
Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64
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(LF_FACESIZE) As Byte
End Type
Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type

Private Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hDC As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, ByVal LParam As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long

Private Declare Function GetFocus Lib "user32" () As Long

'Declare variables required for this module.
Dim WrkCtrl As Control 'will hold the ComboBox or ListBox Control to be filled
Dim FontArray() As String 'The Array that will hold all the Fonts (needed for sorting)
Dim FntInc As Integer 'The FontArray element incremental counter.

Private Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, ByVal FontType As Long, LParam As Long) As Long
Dim FaceName As String

'convert the returned string to Unicode
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)

'Dimension the FontArray array variable to hold the next Font Name.
ReDim Preserve FontArray(FntInc)
'Place the Font name into the newly dimensioned Array element.
FontArray(FntInc) = Left$(FaceName, InStr(FaceName, vbNullChar) - 1)

'continue enumeration
EnumFontFamProc = 1

'Increment the Array Element Counter.
FntInc = UBound(FontArray) + 1
End Function

Public Sub EnumFontToControl(ByVal Frm As String, ByVal Ctrl As String)
Dim LF As LOGFONT
Dim hDC As Long
Dim i As Integer

'Set the WrkCtrl Control variable to the passed
'control we want to fill wih Font Names. This
'control must be either a ComboBox or a ListBox.
Set WrkCtrl = Forms(Frm).Controls(Ctrl)

'Set the Row Source Type for the ComboBox or
'ListBox to "Value List".
WrkCtrl.RowSourceType = "Value List"

'Clear the current List (if any) within the
'control.
WrkCtrl.RowSource = ""

'Retrieve the DC handle of the ComboBox or ListBox
'to be filled. The GetHWND function is also used to
'get the DC.
hDC = GetDC(GetHWND(WrkCtrl))

'Enumerate the fonts
EnumFontFamiliesEx hDC, LF, AddressOf EnumFontFamProc, ByVal 0&, 0

'Finished Enumeration. Release the DC.
ReleaseDC GetHWND(WrkCtrl), hDC

'Sort the FontArray string array.
Call QuickSortStringArray(FontArray(), 0, UBound(FontArray))

'Fill the Passed ComboBox or ListBox Conrol with the
'system Fonts found.
For i = 0 To UBound(FontArray)
WrkCtrl.AddItem Item:=FontArray(i)
Next i

'Free memory...
Set WrkCtrl = Nothing
FntInc = 0
Erase FontArray
End Sub

Public Function GetHWND(Ctrl As Control) As Long
'This function will get the Handle of a MS-Access
'Control.

'Set focus onto the Control we want to get the
'Handle from (this must be done)
Ctrl.SetFocus

'Use the API GetFocus Function to retrieve the
'Handle and return it.
GetHWND = GetFocus&()
End Function

Public Sub QuickSortStringArray(avarIn() As String, ByVal intLowBound As Integer, _
ByVal intHighBound As Integer)
'GENERAL SUB-PROCEDURE
'=====================

'Quicksorts the passed array of Strings
'avarIn() - array of Strings that gets sorted
'intLowBound - low bound of array
'intHighBound - high bound of array

'Declare Variables...
Dim intX As Integer, intY As Integer
Dim varMidBound As Variant, varTmp As Variant

'Trap Errors
On Error GoTo PROC_ERR

'If there is data to sort
If intHighBound > intLowBound Then
'Calculate the value of the middle array element
varMidBound = avarIn((intLowBound + intHighBound) \ 2)
intX = intLowBound
intY = intHighBound

'Split the array into halves
Do While intX <= intY
If avarIn(intX) >= varMidBound And avarIn(intY) <= varMidBound Then
varTmp = avarIn(intX)
avarIn(intX) = avarIn(intY)
avarIn(intY) = varTmp
intX = intX + 1
intY = intY - 1
Else
If avarIn(intX) < varMidBound Then
intX = intX + 1
End If
If avarIn(intY) > varMidBound Then
intY = intY - 1
End If
End If
Loop

'Sort the lower half of the array
QuickSortStringArray avarIn(), intLowBound, intY

'Sort the upper half of the array
QuickSortStringArray avarIn(), intX, intHighBound
End If

PROC_EXIT:
'Outta here
Exit Sub

PROC_ERR:
'Display the Error Trapped
MsgBox "Error: " & Err.Number & ". " & Err.Description, , _
"QuickSortStringArray"
'Jump to...
Resume PROC_EXIT
End Sub

Now, in the Form which contains he ComboBox (or ListBox), place this code into the OnOpen event:

Call EnumFontToControl("yourFormName", "TheComboBoxName")

** Done Deal **

Rather than filling a ComboBox (or ListBox), perhaps you may find it necessary some day to display the Windows Font Dialog window. This can also be done using Windows API Functions. Here's how:

Place this Code into a new Database Code Module:

Option Explicit

Const FW_NORMAL = 400
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const REGULAR_FONTTYPE = &H400

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 * 31
End Type

Private Type CHOOSEFONT
lStructSize As Long
hwndOwner As Long ' caller's window handle
hDC As Long ' printer DC/IC or NULL
lpLogFont As Long ' ptr. to a LOGFONT struct
iPointSize As Long ' 10 * size in points of selected font
flags As Long ' enum. type flags
rgbColors As Long ' returned text color
lCustData As Long ' data passed to hook fn.
lpfnHook As Long ' ptr. to hook function
lpTemplateName As String ' custom template name
hInstance As Long ' instance handle of.EXE that
' contains cust. dlg. template
lpszStyle As String ' return the style field here
' must be LF_FACESIZE or bigger
nFontType As Integer ' same value reported to the EnumFonts
' call back with the extra FONTTYPE_
' bits added
MISSING_ALIGNMENT As Integer
nSizeMin As Long ' minimum pt size allowed &
nSizeMax As Long ' max pt size allowed if
' CF_LIMITSIZE is used
End Type

Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" _
(pChoosefont As CHOOSEFONT) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Public Function ShowFont(ByRef Frm As Form, ByRef FontInfo() As Variant) As Integer
Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
Dim fontname As String, retval As Long
lfont.lfHeight = 0 ' determine default height
lfont.lfWidth = 0 ' determine default width
lfont.lfEscapement = 0 ' angle between baseline and escapement vector
lfont.lfOrientation = 0 ' angle between baseline and orientation vector
lfont.lfWeight = FW_NORMAL ' normal weight i.e. not bold
lfont.lfCharSet = DEFAULT_CHARSET ' use default character set
lfont.lfOutPrecision = OUT_DEFAULT_PRECIS ' default precision mapping
lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS ' default clipping precision
lfont.lfQuality = DEFAULT_QUALITY ' default quality setting
lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN ' default pitch, proportional with serifs
lfont.lfFaceName = "Times New Roman" & vbNullChar ' string must be null-terminated
' Create the memory block which will act as the LOGFONT structure buffer.
hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
pMem = GlobalLock(hMem) ' lock and get pointer
CopyMemory ByVal pMem, lfont, Len(lfont) ' copy structure's contents into block
' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
cf.lStructSize = Len(cf) ' size of structure
cf.hwndOwner = Frm.hwnd ' The Form Handle opening this dialog box
cf.hDC = 0 ' device context of default printer (using VB's mechanism)
cf.lpLogFont = pMem ' pointer to LOGFONT memory block buffer
cf.iPointSize = 120 ' 12 point font (in units of 1/10 point)
cf.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
cf.rgbColors = RGB(0, 0, 0) ' black
cf.nFontType = REGULAR_FONTTYPE ' regular font type i.e. not bold or anything
cf.nSizeMin = 10 ' minimum point size
cf.nSizeMax = 72 ' maximum point size
' Now, call the function. If successful, copy the LOGFONT structure back into the structure
' and then print out the attributes we mentioned earlier that the user selected.
retval = CHOOSEFONT(cf) ' open the dialog box
If retval <> 0 Then ' success
CopyMemory lfont, ByVal pMem, Len(lfont) ' copy memory back
' Now make the fixed-length string holding the font name into a "normal" string.
ReDim Preserve FontInfo(0 To 6)
FontInfo(0) = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
FontInfo(1) = CLng(cf.iPointSize / 10)
FontInfo(2) = cf.rgbColors
FontInfo(3) = IIf(lfont.lfItalic = 0, False, True)
FontInfo(4) = IIf(lfont.lfWeight = 400, False, True)
FontInfo(5) = IIf(lfont.lfStrikeOut = 0, False, True)
FontInfo(6) = IIf(lfont.lfUnderline = 0, False, True)
ShowFont = 1
Else
ShowFont = 0
End If
' Deallocate the memory block we created earlier. Note that this must
' be done whether the function succeeded or not.
retval = GlobalUnlock(hMem) ' destroy pointer, unlock block
retval = GlobalFree(hMem) ' free the allocated memory
End Function

Here we have a public Function named ShowFont. Before you can use this function you will need to declare a Variant Array Variable named FontInfo(). Here is how you would display a Font Dialog Window:

Place this Code into the OnClick event of a Command Button:

Dim FontInfo() As Variant
If ShowFont(Me, FontInfo()) <> 0 Then
MsgBox "Font Name = " & FontInfo(0) & vbCr & _
"Font Size = " & FontInfo(1) & vbCr & _
"Font Color = " & FontInfo(2) & vbCr & _
"Font Italic = " & FontInfo(3) & vbCr & _
"Font Bold = " & FontInfo(4) & vbCr & _
"Font StrikeOut = " & FontInfo(5) & vbCr & _
"Font Underline = " & FontInfo(6), vbInformation, _
"Selected Font Info."
End If

** Done Deal **

As you can tell, I like using API Functions and it's for the simple reason that I don't have to worry about References all the time. :D

Hope this helps.

.