Enum Font List

Category: Fonts

Date: 03-28-2012

Return to Index


 
'Credit Borje
 
'Compilable Example:
'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
' 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 LongAs 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 LongAS 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), CBWPARAMCBLPARAM
         END IF
 
   END SELECT
 
End Function
 
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
   ' WM_DRAWITEM procedure
   'いいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいいい
 
Function DrawCombo(ByVal hWnd AS DWord, ByVal wParam As Long, ByVal lParam As LongAs 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 DWordAs 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 LongAS 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 LongAs Long
   CharSet = elf.elfLogFont.lfCharSet
End Function
 
'gbs_00851
'Date: 03-10-2012


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