Date: 02-16-2022
Return to Index
created by gbSnippets
'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
http://www.garybeene.com/sw/gbsnippets.htm