Enum Font List

Category: Fonts

Date: 02-16-2022

'Credit Borje

'Compilable Example:  (Jose Includes)
'��
' Font ComboBox, ownerdrawn - by Borje Hagsten, January 2003.
' if you prefer listbox, change CB.. messages to LB..
'��
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Include "WIN32API.INC"

%ID_COMBO1 = 120

Declare CallBack Function DlgProc
Declare Function DrawCombo(ByVal hWnd AS DWord, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare SUB FillFontCombo(ByVal hWnd AS DWord)
Declare Function MakeFontEx(ByVal FontName As String, ByVal PointSize As Long, _
   ByVal fBold As Long, ByVal fItalic As Long, _
   ByVal fUnderline As Long) AS DWord
'��
' Main entrance
'��

Function PBMain
   Local hDlg AS DWord, i As Long, txt As String

   DIALOG NEW 0, "OwnerDraw Font Combobox", , , 220, 60, %WS_CAPTION OR %WS_SYSMENU TO hDlg

   CONTROL ADD COMBOBOX, hDlg, %ID_COMBO1, , 5, 15, 210, 120, _
      %CBS_OWNERDRAWFIXED OR %CBS_HASSTRINGS OR %CBS_DROPDOWNLIST OR _
      %CBS_SORT OR %WS_TABSTOP OR %WS_VSCROLL, %WS_EX_CLIENTEDGE

   CONTROL ADD LABEL,  hDlg, 10, "", 6, 5, 210, 10
   CONTROL ADD BUTTON, hDlg, %IDCANCEL, "&Close", 162, 42, 50, 14

   ' nicer with a bit bigger font, so increase line height in control - adjust to own liking.
   CONTROL SEND hDlg, %ID_COMBO1, %CB_GETITEMHEIGHT, 0, 0 TO i    'get current line height
   CONTROL SEND hDlg, %ID_COMBO1, %CB_SETITEMHEIGHT, -1, i + 4    'increase in edit part..
   CONTROL SEND hDlg, %ID_COMBO1, %CB_SETITEMHEIGHT, 0, i + 4     'increase in list..

   FillFontCombo GetDlgItem(hDlg, %ID_COMBO1)

   txt = "Times New Roman" 'search for and select this font, for example..
   CONTROL SEND hDlg, %ID_COMBO1, %CB_SELECTSTRING, -1, STRPTR(txt)
   COMBOBOX GET TEXT hDlg, %ID_COMBO1 TO txt
   CONTROL SET TEXT hDlg, 10, txt

   DIALOG SHOW MODAL hDlg, CALL DlgProc
End Function

   '��
   ' Main dialog callback
   '��

CallBack Function DlgProc
   Local txt As String

   SELECT CASE CBMSG
      CASE %WM_COMMAND
         SELECT CASE CBCTL
            CASE %IDCANCEL
               IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN _
                  DIALOG END CBHNDL 'Exit

            CASE %ID_COMBO1
               IF CBCTLMSG = %CBN_SELCHANGE THEN 'selection change
                  COMBOBOX GET TEXT CBHNDL, %ID_COMBO1 TO txt
                  CONTROL SET TEXT CBHNDL, 10, txt

               ELSEIF CBCTLMSG = %CBN_SELENDOK THEN 'user selected something
                  COMBOBOX GET TEXT CBHNDL, %ID_COMBO1 TO txt
                  MSGBOX txt

               END IF
         END SELECT

      CASE %WM_DRAWITEM 'Pass this one on to DrawCombo
         IF CBWPARAM = %ID_COMBO1 THEN
            DrawCombo GetDlgItem(CBHNDL, %ID_COMBO1), CBWPARAM, CBLPARAM
         END IF

   END SELECT

End Function

   '��
   ' WM_DRAWITEM procedure
   '��

Function DrawCombo(ByVal hWnd AS DWord, ByVal wParam As Long, ByVal lParam As Long) As Long
   Local hFont AS DWord, lpdis AS DRAWITEMSTRUCT PTR
   lpdis = lParam
   IF @lpdis.itemID = &HFFFFFFFF& THEN EXIT Function 'empty list, take a break..

   SELECT CASE As Long @lpdis.itemAction
      CASE %ODA_DRAWENTIRE, %ODA_SELECT
         Local zTxt As AsciiZ * %MAX_PATH

         'CLEAR BACKGROUND
         IF (@lpdis.itemState AND %ODS_SELECTED) = 0 OR _      'if not selected
               (@lpdis.itemState AND %ODS_COMBOBOXEDIT) THEN   'or if in edit part of combo
            SetBkColor @lpdis.hDC, GetSysColor(%COLOR_WINDOW)             'text background
            SetTextColor @lpdis.hDC, GetSysColor(%COLOR_WINDOWTEXT)       'text color
            FillRect @lpdis.hDC, @lpdis.rcItem, GetSysColorBrush(%COLOR_WINDOW) 'clear background
         ELSE
            SetBkColor @lpdis.hDC, GetSysColor(%COLOR_HIGHLIGHT)             'sel text background
            SetTextColor @lpdis.hDC, GetSysColor(%COLOR_HIGHLIGHTTEXT)       'sel text color
            FillRect @lpdis.hDC, @lpdis.rcItem, GetSysColorBrush(%COLOR_HIGHLIGHT) 'clear background
         END IF

         'GET ITEM'S TEXT (FONTNAME), CREATE FONT AND DRAW TEXT
         SendMessage hWnd, %CB_GETLBTEXT, @lpdis.itemID, VARPTR(zTxt)  'Get text
         IF LEN(zTxt) THEN
            hFont = MakeFontEx(zTxt, 12, 0, 0, 0)
            IF hFont THEN hFont = SelectObject(@lpdis.hDC, hFont)
         END IF

         DrawText @lpdis.hDC, zTxt, LEN(zTxt), @lpdis.rcItem, _
            %DT_SINGLELINE OR %DT_LEFT OR %DT_VCENTER

         IF hFont THEN DeleteObject SelectObject(@lpdis.hDC, hFont)

         'FOCUS RECT AROUND SELECTED ITEM
         IF (@lpdis.itemState AND %ODS_SELECTED) THEN      'if selected
            CALL DrawFocusRect(@lpdis.hDC, @lpdis.rcItem)  'draw a focus rectangle around all
         END IF
         Function = %TRUE

   END SELECT

End Function

   '��
   ' Fill a combo box with the names of all fonts of a certain type
   '��

Sub FillFontCombo(ByVal hWnd AS DWord)
   Local hDC AS DWord

   SendMessage hWnd, %CB_RESETCONTENT, 0, 0
   hDC = GetDC(%HWND_DESKTOP)
   EnumFontFamilies hDC, ByVal %NULL, CODEPTR(EnumFontName), ByVal VARPTR(hWnd)
   ReleaseDC %HWND_DESKTOP, hDC
End Sub

   '��
   ' Enumerate the names of all the fonts. Note the difference between
   ' how to enumerate them - %TMPF_FIXED_PITCH has the bit cleared..
   ' %TMPF_FIXED_PITCH for fixed pitch fonts (like in PB edit)
   ' %TMPF_TRUETYPE OR %TMPF_VECTOR for True type and vector fonts
   ' %TMPF_DEVICE for device fonts (like printer fonts)
   ' Exclude what you don't want to include in list.
   '��

Function EnumFontName(lf AS LOGFONT, tm AS TEXTMETRIC, ByVal FontType As Long, hWnd AS DWord) As Long

   IF (FontType AND %TRUETYPE_FONTTYPE) THEN        ' true type fonts
      SendMessage hWnd, %CB_ADDSTRING, 0, VARPTR(lf.lfFaceName)
   ELSEIF (FontType AND %TMPF_FIXED_PITCH) = 0 THEN ' <- check if bit is cleared!
      SendMessage hWnd, %CB_ADDSTRING, 0, VARPTR(lf.lfFaceName) ' fixed pitch fonts
   ELSEIF (FontType AND %TMPF_VECTOR) THEN
      SendMessage hWnd, %CB_ADDSTRING, 0, VARPTR(lf.lfFaceName) ' vector fonts
   ELSEIF (FontType AND %TMPF_DEVICE) THEN
      SendMessage hWnd, %CB_ADDSTRING, 0, VARPTR(lf.lfFaceName) ' device fonts
   ELSE
      SendMessage hWnd, %CB_ADDSTRING, 0, VARPTR(lf.lfFaceName) ' system, fonts - the rest..
   END IF

   Function = 1
End Function

   '��
   ' Create a desirable font and return its handle. Original code by Dave Navarro
   ' NOTE: enhanced with proper enumeration of character set via chmEnumFontDataProc
   '��

Function MakeFontEx(ByVal FontName As String, ByVal PointSize As Long, ByVal fBold As Long, _
      ByVal fItalic As Long, ByVal fUnderline As Long) AS DWord
   Local hDC AS DWord, CharSet As Long, CyPixels As Long

   hDC = GetDC(%HWND_DESKTOP)
   CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
   EnumFontFamilies hDC, ByVal STRPTR(FontName), CODEPTR(EnumCharSet), ByVal VARPTR(CharSet)
   ReleaseDC %HWND_DESKTOP, hDC
   PointSize = 0 - (PointSize * CyPixels) \ 72

   Function = CreateFont(PointSize, 0, _  'height, width(default=0)
      0, 0, _                     'escapement(angle), orientation
      fBold, _                    'weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700)
      fItalic, _                  'Italic
      fUnderline, _               'Underline
      %FALSE, _                   'StrikeThru
      CharSet, %OUT_TT_PRECIS, _
      %CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _
      %FF_DONTCARE , BYCOPY FontName)
End Function

   '��
   ' Get type of character set - ansi, symbol.. a must for some fonts.
   '��

Function EnumCharSet (elf AS ENUMLOGFONT, ntm AS NEWTEXTMETRIC, _
      ByVal FontType As Long, CharSet As Long) As Long
   CharSet = elf.elfLogFont.lfCharSet
End Function

'gbs_00851
'Date: 03-10-2012

created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm