- Removed dependency from SetWindowCallback()
- Removed bug which made the code crash without using SetGagdetState() after creating the gadget
- Restructured, optimized and bundled code into compact set of functions
- You can now create multiple font preview combo boxes without the code crashing
- You can now specify item height and preview font size
Update #2:
- Added: CFP_GetGadgetText(Gadget,Item)
Code: Select all
; Title: Font Preview ComboBox
; Author: Fluid Byte
; Platform: Windows
; Created: Jan 27, 2009
; Updated: May 29, 2017
; E-Mail: fluidbyte@web.de
EnableExplicit
Declare CFP_CreateGagdet(Gadget,X,Y,Width,Height,ItemHeight=20,FontSize=11)
Declare.s CFP_GetGadgetText(Gadget,Item)
Declare CFP_FreeGadget(Gadget)
Declare CFP_EnumFonts(Gadget)
Declare CFP_EnumProc(*lpelfe.ENUMLOGFONTEX,*lpntme.NEWTEXTMETRICEX,FontType,lParam)
Declare CFP_WndProc(hWnd,uMsg,wParam,lParam)
Structure CFP_FONTDATA
Type.b
Symbol.b
Name.s
EndStructure
Structure CFP_USERDATA
himlFontType.i
FontSize.b
hwndParent.i
EndStructure
Global NewList ftd.CFP_FONTDATA()
Define EventID, Quit
OpenWindow(0,0,0,320,240,"Font Preview ComboBox",#WS_OVERLAPPEDWINDOW | #PB_Window_ScreenCentered)
CFP_CreateGagdet(101,10,10,300,24)
; ---------------------------------------------------------------------------------------
; MAIN LOOP
; ---------------------------------------------------------------------------------------
Repeat
EventID = WaitWindowEvent()
If EventID = #PB_Event_CloseWindow
; The ImageList used will remain in memory even after you quit, you have to free it manually
CFP_FreeGadget(101)
Quit = 1
EndIf
Until Quit = 1
; ---------------------------------------------------------------------------------------
; FUNCTIONS
; ---------------------------------------------------------------------------------------
Procedure CFP_CreateGagdet(Gadget,X,Y,Width,Height,ItemHeight=20,FontSize=11)
Protected himlFontType, hwndParent, *cfpu.CFP_USERDATA
himlFontType = ImageList_Create_(16,12,#ILC_MASK,0,0)
ImageList_AddMasked_(himlFontType,CatchImage(0,?FontType),#Yellow)
hwndParent = GadgetID(ContainerGadget(#PB_Any,X,Y,Width,Height))
ComboBoxGadget(Gadget,0,0,Width,Height,#CBS_OWNERDRAWFIXED)
SendMessage_(GadgetID(Gadget),#CB_SETITEMHEIGHT,0,ItemHeight)
CloseGadgetList()
*cfpu = AllocateMemory(SizeOf(CFP_USERDATA))
*cfpu\himlFontType = himlFontType
*cfpu\FontSize = FontSize
*cfpu\hwndParent = hwndParent
SetWindowLongPtr_(GadgetID(Gadget),#GWLP_USERDATA,*cfpu)
SetWindowLongPtr_(hwndParent,#GWL_WNDPROC,@CFP_WndProc())
CFP_EnumFonts(Gadget)
SetGadgetState(Gadget,0)
EndProcedure
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Procedure.s CFP_GetGadgetText(Gadget,Item)
If IsGadget(Gadget)
Protected *cfpf.CFP_FONTDATA
*cfpf = GetGadgetItemData(Gadget,Item)
ProcedureReturn *cfpf\Name
EndIf
EndProcedure
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Procedure CFP_FreeGadget(Gadget)
If IsGadget(Gadget)
Protected *cfpu.CFP_USERDATA, Result
*cfpu = GetWindowLongPtr_(GadgetID(Gadget),#GWLP_USERDATA)
If *cfpu
Result = ImageList_Destroy_(*cfpu\himlFontType)
If Result : Result = FreeMemory(*cfpu) : EndIf
EndIf
EndIf
ProcedureReturn Result
EndProcedure
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Procedure CFP_WndProc(hWnd,uMsg,wParam,lParam)
Select uMsg
Case #WM_DRAWITEM
Protected *lpdis.DRAWITEMSTRUCT = lParam
; --- Draw item focus rectangle or normal state
If *lpdis\itemState & #ODS_SELECTED
Protected hbrFocus = CreateSolidBrush_(GetSysColor_(#COLOR_HIGHLIGHT))
FillRect_(*lpdis\hDC,*lpdis\rcItem,hbrFocus)
DeleteObject_(hbrFocus)
DrawFocusRect_(*lpdis\hDC,*lpdis\rcItem)
SetTextColor_(*lpdis\hDC,GetSysColor_(#COLOR_HIGHLIGHTTEXT))
Else
Protected hbrFace = CreateSolidBrush_(GetSysColor_(#COLOR_WINDOW))
FillRect_(*lpdis\hDC,*lpdis\rcItem,hbrFace)
DeleteObject_(hbrFace)
SetTextColor_(*lpdis\hDC,GetSysColor_(#COLOR_WINDOWTEXT))
EndIf
Protected *ftd.CFP_FONTDATA = GetGadgetItemData(wParam,*lpdis\itemID)
Protected *cfpu.CFP_USERDATA = GetWindowLongPtr_(*lpdis\hwndItem,#GWLP_USERDATA)
; --- Draw Font Icons
If *ftd\Type > -1
ImageList_Draw_(*cfpu\himlFontType,*ftd\Type,*lpdis\hDC,2,*lpdis\rcItem\top + 3,#ILD_TRANSPARENT)
EndIf
; --- Create Preview Font
Protected lplf.LOGFONT, hfntPreview
lplf\lfHeight = -MulDiv_(*cfpu\FontSize,GetDeviceCaps_(*lpdis\hDC,#LOGPIXELSY),72)
If *ftd\Symbol : lplf\lfCharSet = #SYMBOL_CHARSET : EndIf
PokeS(@lplf\lfFaceName,*ftd\name)
hfntPreview = CreateFontIndirect_(lplf)
; --- Draw Preview Text
SetBkMode_(*lpdis\hDC,#TRANSPARENT)
If *ftd\Symbol ; If it's a smybol font like Webdings
Protected fsz.SIZE
; Write the fonts name
*lpdis\rcItem\left + 20
SelectObject_(*lpdis\hDC,GetStockObject_(#DEFAULT_GUI_FONT))
GetTextExtentPoint32_(*lpdis\hDC,*ftd\Name,Len(*ftd\Name),fsz)
DrawText_(*lpdis\hDC,*ftd\Name,-1,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)
; Display demo charachters next to the name
*lpdis\rcItem\left + fsz\cx + 3
SelectObject_(*lpdis\hDC,hfntPreview)
DrawText_(*lpdis\hDC,"ABC123",6,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)
Else
*lpdis\rcItem\left + 20
SelectObject_(*lpdis\hDC,hfntPreview)
DrawText_(*lpdis\hDC,*ftd\Name,-1,*lpdis\rcItem,#DT_SINGLELINE | #DT_VCENTER)
EndIf
DeleteObject_(hfntPreview)
ProcedureReturn #True
EndSelect
ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Procedure CFP_EnumFonts(Gadget)
Protected lplf.LOGFONT, hdc, Index
lplf\lfCharset = #DEFAULT_CHARSET
hdc = GetDC_(0)
EnumFontFamiliesEx_(hdc,lplf,@CFP_EnumProc(),hdc,0)
ReleaseDC_(0,hdc)
SortStructuredList(ftd(),#PB_Sort_Ascending,OffsetOf(CFP_FONTDATA\Name),#PB_String)
ForEach ftd()
AddGadgetItem(Gadget,-1,ftd()\Name)
SetGadgetItemData(Gadget,Index,ftd())
Index + 1
Next
EndProcedure
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Procedure CFP_EnumProc(*lpelfe.ENUMLOGFONTEX,*lpntme.NEWTEXTMETRICEX,FontType,lParam)
Protected CHRSET = *lpelfe\elfLogFont\lfCharSet & 255
; WESTERN FONTS / SYSTEM FONTS / SYMBOL FONTS
If CHRSET = #ANSI_CHARSET Or CHRSET = #OEM_CHARSET Or CHRSET = #SYMBOL_CHARSET
AddElement(ftd())
Select FontType
Case #TRUETYPE_FONTTYPE : ftd()\Type = 0
Case #DEVICE_FONTTYPE : ftd()\Type = 1
Case #RASTER_FONTTYPE : ftd()\Type = 2
Default : ftd()\Type = -1
EndSelect
If CHRSET = #SYMBOL_CHARSET : ftd()\Symbol = 1 : EndIf
; Using 'lfFaceName' of the LOGFONT structure gives unique fontnames and avoids dublicates.
; When using 'elfFullName' of the ENUMLOGFONTEX structure you still can get dublicates even
; though you limit the character set like above. Also you don't need to cycle through the
; whole LinkedList everytime to find out if a fontname already exists.
;
; The created fontlist SHOULD be identical to the one in MS Wordpad + bitmap fonts (Courier, etc.)
ftd()\Name = PeekS(@*lpelfe\elfLogFont\lfFaceName)
EndIf
ProcedureReturn #True
EndProcedure
; ---------------------------------------------------------------------------------------
; DATA SECTION
; ---------------------------------------------------------------------------------------
DataSection
FontType:
Data.l $01964D42,$00000000,$00760000,$00280000,$00300000,$000C0000,$00010000,$00000004,$01200000,$00000000
Data.l $00000000,$00000000,$00000000,$00000000,$00000000,$80000080,$80000000,$00800080,$00800000,$80800080
Data.l $80800000,$C0C00080,$000000C0,$FF0000FF,$FF000000,$00FF00FF,$00FF0000,$FFFF00FF,$FFFF0000,$BBBB00FF
Data.l $5555BBBB,$BBBBBB55,$BB7B77B8,$B9BBBBBB,$97B97B99,$BBBBBBBB,$55BBBBBB,$BBBBBBBB,$8B868870,$99BBBBBB
Data.l $79999799,$BBBBBBBB,$55BBBBBB,$B8BBBBBB,$68B8BB00,$99BBBBBB,$B799797B,$BBBBBB9B,$55666666,$B8BBBBBB
Data.l $76BBBB00,$99BBBB8B,$7B99B77B,$BBBBBBBB,$55BB66BB,$B8BBBBBB,$86BBBB00,$99BBBB6B,$9B79BB7B,$BBBBBBBB
Data.l $55BB65BB,$B8BB5BBB,$B6BB8B00,$79BBBB68,$97B9BB9B,$BBBBBBBB,$55BB65BB,$BBBB5BBB,$B6BB7B00,$B9BBBB68
Data.l $99B7BB97,$BBBBBBBB,$555B65BB,$BBBB5BB5,$B7BB0B70,$B7BBBB66,$99BBBB99,$B6BBBB7B,$555565BB,$BBBB5B55
Data.l $B7BB08B0,$BBBBBB68,$79BB9B79,$B6BBBB9B,$6BBB66BB,$BBBBBBBB,$B7BB00B8,$BBBBBB68,$79BB99B7,$B6BBBB97
Data.l $6BB6666B,$BBBBBBBB,$867880BB,$BBBBBB6B,$9799B9BB,$B6BBBB79,$6B666666,$BBBBBBBB,$6887BBBB,$BBBBBBBB
Data.l $BBBBBBBB
Data.b $BB,$BB
EndDataSection
very usefull
- almost the half of the screen here 
