RychlejÜφ naΦφtßnφ font∙ do Comba

Postup:
V∞tÜina z Vßs, kdy₧ chce naΦφtat seznam nainstalovan²ch font∙ do comba, urΦit∞ pou₧φvß nßsledujφcφ proceduru:
For I = 1 To Screen.FontCount - 1
   
       Combo.AddItem Screen.Fonts(I)
  
Next

Pokud je nainstalovßno hodn∞ font∙, je to na kafe a cigßrko. Nabφzφm metodu, kterß pou₧φvß API EnumFontFamilies. Pomocφ jejφho volßnφ lze dosßhnout naΦφtßnφ font∙, kterΘ je o 2/3 rychlejÜφ jako standardnφ metoda ...

Do modulu zapiÜte:

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(LF_FACESIZE) As Byte
End Type

Private 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 EnumFontFamilies Lib "gdi32" _
   Alias "EnumFontFamiliesA" (ByVal hdc As Long, _
   ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, _
   lParam As Any) 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

Public Sub AddFonts(Combo As ComboBox)

   Dim hdc As Long

   Combo.Clear
   hdc = GetDC(Combo.hwnd)
   EnumFontFamilies hdc, vbNullString, AddressOf EnumFontFamProc, Combo
   ReleaseDC Combo.hwnd, hdc

End Sub

Private Function EnumFontFamProc _
   (lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, _
   ByVal FontType As Long, lParam As ComboBox) As Long

   Dim FaceName As String

   FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
   lParam.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
   EnumFontFamProc = 1

End Function

Zp∞t