How to use Screen.Fonts Collection in VBA?

[DancingGerbil]

Hi, new to VBA and this forum, hope this is the right place to ask.

I'm using Access 2003.

I have a need to get the name for all fonts installed on the system and populate a combo box with these names.

In VB6 I can do something like:

For i = 1 To Screen.FontCount
ItemsFont.AddItem i, Screen.Fonts(i)
Next i

But can't seem to find a solution in VBA.

I seen a solution that suggested to create a DLL in VB6 and use it in VBA, but I have no experience with this and can not get that approach to work due to my lack of experience.

Please Help!!!!!
TIA

 

[CyberLynx]

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.

Hope this helps.

.

 

[jwhite]

CyberLynx,

Many thanks for posting that code for the Font ListBox! I had scoured forever trying to find something like it for Access VBA! Am curious why the Wingding fonts (and a handful of others) do not show up. There are 292 font files in my Fonts folder, and the .ListCount = 271.

My purpose is obviously not 'Production' related, but rather a method to "broaden my horizon"

[WinXP; Ac2003 SP2]

 

[AndyT]

sir,
this worked great for me too, but i also need to list all the available font sizes for a selected font. ideally, call a subroutine for the selected font and populate another list box. i use access 2003, vb 6.5.

another beginner...

cheers