An alternative FontRequester [Windows only]
Posted: Mon Mar 10, 2025 8:18 pm
The native FontRequester() used on Windows is not easily customizable and cannot be colored in the case of a 'Dark Mode' interface. (It is also not very pretty). So I decided to recreate a more adaptable one.
Here are two of the possible appearances, depending on the settings.
The following code is just for demo. Due to the size limit of this forum, it has very few comments and explanations.
It is NOT the last version of this library which is too big to fit in a forum post.
Please, visit https://www.editions-humanis.com/downlo ... ads_EN.htm
and go to "Zapman Font Requester" to get the last version.
Here are two of the possible appearances, depending on the settings.
The following code is just for demo. Due to the size limit of this forum, it has very few comments and explanations.
It is NOT the last version of this library which is too big to fit in a forum post.
Please, visit https://www.editions-humanis.com/downlo ... ads_EN.htm
and go to "Zapman Font Requester" to get the last version.
Code: Select all
;
; ****************************************************************************
;
; Zapman Font Requester
; March 2025 - 12 - Forum
;
; This file should be saved under the name "ZapmanFontRequester.pbi".
;
; This version of the code has not comments to comply to the size limitation of the forum.
; Please visit https://www.editions-humanis.com/downloads/PureBasic/ZapmanDowloads_EN.htm
; to get the last and full commented version for this code.
;
; This library is intended to implement an alternative
; of the PureBasic native FontRequester() function.
;
Global MyLanguage$
If MyLanguage$ = ""
MyLanguage$ = "EN" ; You can set MyLanguage$ to "EN", "DE", "ES" or "FR".
EndIf
;
CompilerIf Not Defined(LanguageListStructure, #PB_Structure)
Structure LanguageListStructure
Language$
LanguageEntry$
LanguageTranslation$
EndStructure
;
Global NewList LanguageList.LanguageListStructure()
CompilerEndIf
;
CompilerIf Not Defined(GetTextFromCatalog, #PB_Procedure)
Procedure.s GetTextFromCatalog(SName$)
ForEach LanguageList()
If LanguageList()\Language$ = MyLanguage$ And LCase(LanguageList()\LanguageEntry$) = LCase(SName$)
ProcedureReturn LanguageList()\LanguageTranslation$
EndIf
Next
ProcedureReturn SName$
EndProcedure
CompilerEndIf
;
CompilerIf Not Defined(FillLanguageList, #PB_Procedure)
Procedure FillLanguageList(Language$, LanguageEntry$, LanguageTranslation$)
;
Protected PosInList = 0, KeyWord$, Found
;
Repeat
PosInList + 1
KeyWord$ = StringField(LanguageEntry$, PosInList, ",")
Found = 0
ForEach LanguageList()
If LanguageList()\Language$ = Language$ And LCase(LanguageList()\LanguageEntry$) = LCase(KeyWord$)
Found = 1
Break
EndIf
Next
If Found = 0
AddElement(LanguageList())
LanguageList()\Language$ = Language$
LanguageList()\LanguageEntry$ = KeyWord$
LanguageList()\LanguageTranslation$ = StringField(LanguageTranslation$, PosInList, ",")
EndIf
Until KeyWord$ = ""
EndProcedure
CompilerEndIf
;
Define LanguageEntry$ = "ChooseAFont,Variants:,Size:,DetailsDwn,DetailsUp,Cancel,OK,Normal,Bold,Italic,Underline,StrikeOut,Color:,"
LanguageEntry$ + "fancyFont,unspecified,monospace,withSerif,handwriting,withoutSerif,Unknown,Type:,Family:,Style:,Script(s):,Metrics:,"
LanguageEntry$ + "Sample,"
LanguageEntry$ + "CAFDemoText"
;
; ------------- English list of expressions ---------------
Define LanguageTranslation$ = "Choose a font,Variants:,Size:,Details ⏷,Details ⏶,Cancel,OK,Normal,Bold,Italic,Underline,StrikeOut,Color:,"
LanguageTranslation$ + "fancy font,unspecified,monospace,with serif,handwriting,without serif,Unknown,Type:,Family:,Style:,Script(s):,Metrics:,"
LanguageTranslation$ + "Sample,"
LanguageTranslation$ + "The invisible worm" + #CR$
LanguageTranslation$ + "That flies in the night" + #CR$
LanguageTranslation$ + "In the howling storm" + #CR$
LanguageTranslation$ + "Has found out thy bed" + #CR$
LanguageTranslation$ + "Of crimson joy:" + #CR$
LanguageTranslation$ + "his dark secret love" + #CR$
LanguageTranslation$ + "thy life destroy."
FillLanguageList("EN", LanguageEntry$, LanguageTranslation$)
;
; ------------- Lista de expresiones en español ---------------
Define LanguageTranslation$ = "Elige una fuente,Variantes:,Tamaño:,Detalles ⏷,Detalles ⏶,Cancelar,OK,Normal,Negrita,Cursiva,Subrayado,Tachado,Color:,"
LanguageTranslation$ + "fuente elegante,no especificada,monoespaciada,con serif,escritura manual,sin serif,Desconocido,Tipo:,Familia:,Estilo:,Guion(es):,Métricas:,"
LanguageTranslation$ + "Muestra,"
LanguageTranslation$ + "Recuerde el alma dormida" + #CR$
LanguageTranslation$ + "avive el seso y despierte" + #CR$
LanguageTranslation$ + "contemplando cómo se pasa la vida" + #CR$
LanguageTranslation$ + "cómo se viene la muerte tan callando."
FillLanguageList("ES", LanguageEntry$, LanguageTranslation$)
;
; ------------- French list of expressions ----------------
LanguageTranslation$ = "Choisir une police,Variantes :,Taille :,Détails ⏷,Détails ⏶,Annuler,OK,Normal,Gras,Italique,Souligné,Barré,Couleur :,"
LanguageTranslation$ + "police fantaisie,non spécifié,monospace,avec empattement,écriture manuelle,sans empattement,Inconnu,Type :,Famille :,Style :,Script(s) :,Métriques :,"
LanguageTranslation$ + "Exemple,"
LanguageTranslation$ + "Toujours avec l'espoir de rencontrer la mer" + #CR$
LanguageTranslation$ + "Ils voyageaient sans pain sans bâtons et sans urnes" + #CR$
LanguageTranslation$ + "Mordant au citron d'or de l'idéal amer."
FillLanguageList("FR", LanguageEntry$, LanguageTranslation$)
;
; ------------- German list of expressions ----------------
Define LanguageTranslation$ = "Wählen Sie eine Schriftart,Varianten:,Größe:,Einzelheiten ⏷,Einzelheiten ⏶,Abbrechen,OK,Normal,Fett,Kursiv,Unterstrichen,Durchgestrichen,Farbe:,"
LanguageTranslation$ + "elegante Schrift,nicht angegeben,monospaced,mit serifen,handschrift,ohne serifen,Unbekannt,Typ:,Familie:,Stil:,Schriftart(en):,Metriken:,"
LanguageTranslation$ + "Probe,"
LanguageTranslation$ + "Wer reitet so spät durch Nacht und Wind?" + #CR$
LanguageTranslation$ + "Es ist der Vater mit seinem Kind;" + #CR$
LanguageTranslation$ + "Er hat den Knaben wohl in dem Arm" + #CR$
LanguageTranslation$ + "Er fasst ihn sicher er hält ihn warm."
FillLanguageList("DE", LanguageEntry$, LanguageTranslation$)
;
; ----------- Add your own language here -------------
; LanguageTranslation$ = "Expression1,Expression2,etc."
;FillLanguageList("XX", LanguageEntry$, LanguageTranslation$) ; and replace "XX" by the abbreviation of your language name.
;
;
; ****************************************************************************
;
;- 2. General functions for font recognition
;
; ****************************************************************************
;
Global PBBAllGadgetsFont
If PBBAllGadgetsFont = 0
; Define the font used to print gadgets of the FontRequesterEx() window.
PBBAllGadgetsFont = FontID(LoadFont(#PB_Any, "Segoe UI", 9))
EndIf
;
Procedure.s GetFontName(FontID)
Protected FontName$
;
If IsFont(FontID)
FontID = FontID(FontID)
EndIf
;
CompilerIf #PB_Compiler_OS = #PB_OS_MacOS
Protected string
If FontID
string = CocoaMessage(0, FontID, "displayName")
If string
FontName$ = PeekS(CocoaMessage(0, string, "UTF8String"), -1, #PB_UTF8)
EndIf
EndIf
CompilerElseIf #PB_Compiler_OS = #PB_OS_Windows
Protected hdc = GetDC_(#Null)
Protected oldFont = SelectObject_(hdc, FontID)
FontName$ = Space(#LF_FACESIZE)
GetTextFace_(hdc, #LF_FACESIZE, @FontName$)
If FontName$ = "" : FontName$ = "Arial" : EndIf
SelectObject_(hdc, oldFont)
ReleaseDC_(#Null, hdc)
CompilerEndIf
;
ProcedureReturn FontName$
;
EndProcedure
;
Procedure.f GetFontSize(FontID)
Protected FpointSize.f
;
If IsFont(FontID)
FontID = FontID(FontID)
EndIf
;
CompilerIf #PB_Compiler_OS = #PB_OS_MacOS
Protected pointSize.CGFloat = 0.0
;
If FontID
CocoaMessage(@pointSize, FontID, "pointSize")
EndIf
FpointSize = pointSize
ProcedureReturn FpointSize
CompilerElseIf #PB_Compiler_OS = #PB_OS_Windows
Protected finfo.LOGFONT
Protected hdc = GetDC_(#Null)
If GetObject_(FontID, SizeOf(LOGFONT), @finfo.LOGFONT)
FpointSize = -finfo\lfHeight * 72 / GetDeviceCaps_(hdc, #LOGPIXELSY)
EndIf
ProcedureReturn FpointSize
CompilerEndIf
;
EndProcedure
;
Procedure GetNumStyleFromAttributesDescription(StyleDescription$)
Protected FontStyle = 0
StyleDescription$ = LCase(StyleDescription$)
;
If FindString(StyleDescription$, "italic") Or FindString(StyleDescription$, LCase(GetTextFromCatalog("italic")))
FontStyle = #PB_Font_Italic
EndIf
If FindString(StyleDescription$, "bold") Or FindString(StyleDescription$, LCase(GetTextFromCatalog("bold")))
FontStyle | #PB_Font_Bold
EndIf
If FindString(StyleDescription$, "strikeout") Or FindString(StyleDescription$, LCase(GetTextFromCatalog("strikeout")))
FontStyle | #PB_Font_StrikeOut
EndIf
If FindString(StyleDescription$, "underline") Or FindString(StyleDescription$, LCase(GetTextFromCatalog("underline")))
FontStyle | #PB_Font_Underline
EndIf
ProcedureReturn FontStyle
EndProcedure
;
; ****************************************************************************
;
;- 3. Zapman FontRequester specific functions
;
; ****************************************************************************
;
#ZFR_ChooseColor = $4000000
#ZFR_NORASTERFONTS = $8000000
#ZFR_ShowSize = $10000000
#ZFR_FontRequester_Effects = #PB_Font_Bold | #PB_Font_Italic | #PB_Font_StrikeOut | #PB_Font_Underline | #ZFR_ChooseColor | #ZFR_ShowSize | #CF_NOVERTFONTS
#ZFR_FontRequester_Default = #PB_Font_Bold | #PB_Font_Italic | #ZFR_ShowSize | #CF_NOVERTFONTS
;
Global ZFR_FontDescription$
;
CompilerIf Not Defined(ComputeWinOrigins, #PB_Procedure)
Procedure ComputeWinOrigins(*OX.Integer, *OY.Integer, WWidth, WHeight, ParentWindow = #PB_Default, XShiftOrPos = 0, YShiftOrPos = 0)
Protected CurrentDesktop, DesktopLeft, DesktopRight, DesktopTop, DesktopBottom
Protected NBrDesktop = ExamineDesktops(), ParentWindowID
;
If ParentWindow = #PB_Default And IsWindow(GetActiveWindow())
ParentWindow = GetActiveWindow()
EndIf
;
If ParentWindow = -2
*OX\i = XShiftOrPos
*OY\i = YShiftOrPos
ProcedureReturn 0
ElseIf IsWindow(ParentWindow)
Protected ParentWindowX = WindowX(ParentWindow)
Protected ParentWindowY = WindowY(ParentWindow)
;
Repeat
If ParentWindowX >= DesktopX(CurrentDesktop) And ParentWindowX <= DesktopX(CurrentDesktop) + DesktopWidth(CurrentDesktop)
If ParentWindowY >= DesktopY(CurrentDesktop) And ParentWindowY <= DesktopY(CurrentDesktop) + DesktopHeight(CurrentDesktop)
Break
EndIf
EndIf
CurrentDesktop + 1
Until CurrentDesktop = NBrDesktop
ParentWindowID = WindowID(ParentWindow)
Else
CurrentDesktop = 0
EndIf
;
Protected hMonitor, mi.MONITORINFO
hMonitor = MonitorFromWindow_(ParentWindowID, #MONITOR_DEFAULTTONEAREST)
mi\cbSize = SizeOf(MONITORINFO)
GetMonitorInfo_(hMonitor, @mi)
;
DesktopLeft = DesktopX(CurrentDesktop)
DesktopRight = DeskTopLeft + DesktopUnscaledX(mi\rcMonitor\Right)
DesktopTop = DesktopY(CurrentDesktop)
DesktopBottom = DesktopTop + DesktopUnscaledY(mi\rcMonitor\Bottom)
;
If IsWindow(ParentWindow)
*OX\i = WindowX(ParentWindow) + (WindowWidth(ParentWindow) - WWidth) / 2 + XShiftOrPos
*OY\i = WindowY(ParentWindow) + (WindowHeight(ParentWindow) - WHeight) / 2 + YShiftOrPos
Else
*OX\i = (DeskTopLeft + DeskTopRight) / 2
*OY\i = (DesktopTop + DesktopBottom) / 2
;
*OX\i - WWidth / 2 + XShiftOrPos
*OY\i - WHeight / 2 + YShiftOrPos
EndIf
;
If *OX\i < DesktopLeft
*OX\i = DesktopLeft + 10
ElseIf *OX\i + WWidth > DesktopRight
*OX\i = DesktopRight - WWidth - 10
EndIf
If *OY\i < DesktopTop + 80
*OY\i = DesktopTop + 80
ElseIf *OY\i + WHeight > DesktopBottom - 40
*OY\i = DesktopBottom - WHeight - 40
EndIf
;
ProcedureReturn ParentWindowID
EndProcedure
CompilerEndIf
;
Structure FontInfoStruct
FontName$
FontStyle$
ScriptList$
FontType.i
PitchAndFamily.l
ntmFlags.i
;
MainFontName$
Variants$
EndStructure
;
Define NewList FontList.FontInfoStruct()
;
Procedure.s ZFR_GetFontTypeNameFromNum(FontType)
Protected FontTypeStr$
Select FontType
Case #TRUETYPE_FONTTYPE
FontTypeStr$ = "TrueType"
Case #DEVICE_FONTTYPE
FontTypeStr$ = "Device"
Case #RASTER_FONTTYPE
FontTypeStr$ = "Raster"
Default
FontTypeStr$ = "Unknown"
EndSelect
ProcedureReturn FontTypeStr$
EndProcedure
;
Procedure.s ZFR_GetFontFamilyNameFromNum(PitchAndFamily)
Protected FontFamilyStr$
Protected FamilyNum = PitchAndFamily & $FFF0
Select FamilyNum
Case #FF_DECORATIVE
FontFamilyStr$ = "DECORATIVE (" + GetTextFromCatalog("fancyFont") + ")"
Case #FF_DONTCARE
FontFamilyStr$ = "DONTCARE (" + GetTextFromCatalog("unspecified") + ")"
Case #FF_MODERN
FontFamilyStr$ = "MODERN (" + GetTextFromCatalog("monospace") + ")"
Case #FF_ROMAN
FontFamilyStr$ = "ROMAN (" + GetTextFromCatalog("withSerif") + ")"
Case #FF_SCRIPT
FontFamilyStr$ = "SCRIPT (" + GetTextFromCatalog("handwriting") + ")"
Case #FF_SWISS
FontFamilyStr$ = "SWISS (" + GetTextFromCatalog("withoutSerif") + ")"
Default
FontFamilyStr$ = "Unknown"
EndSelect
If PitchAndFamily & 1 And FindString(FontFamilyStr$, GetTextFromCatalog("monospace")) = 0
FontFamilyStr$ + " (" + GetTextFromCatalog("monospace") + ")"
EndIf
ProcedureReturn FontFamilyStr$
EndProcedure
;
Procedure ZFR_EnumFontProc(*lpelfex.ENUMLOGFONTEX, *lpntm.NEWTEXTMETRIC, FontType, lParam)
;
Shared FontList()
Protected FontName$ = PeekS(@*lpelfex\elfLogFont\lfFaceName[0]) ; Retrieve the font name
Protected ScriptList$ = PeekS(@*lpelfex\elfScript[0])
;
If Left(FontName$, 1) <> "@" Or lParam & #CF_NOVERTFONTS = 0
If *lpelfex\elfLogFont\lfPitchAndFamily & #TMPF_FIXED_PITCH Or lParam & #CF_FIXEDPITCHONLY = 0
If FontType <> #RASTER_FONTTYPE Or lParam & #ZFR_NORASTERFONTS = 0
If FontType & #TMPF_TRUETYPE Or lParam & #CF_TTONLY = 0
If FindString(ScriptList$, "OEM") = 0 Or (lParam & #CF_NOOEMFONTS = 0 And lParam & #CF_NOVECTORFONTS = 0)
If (FindString(ScriptList$, "OEM") = 0 And FindString(ScriptList$, "Symbol") = 0) Or lParam & #CF_SCRIPTSONLY = 0
If ListSize(FontList()) < 1 Or FontName$ <> FontList()\FontName$
AddElement(FontList())
FontList()\FontName$ = FontName$
FontList()\FontStyle$ = PeekS(@*lpelfex\elfStyle[0])
FontList()\FontType = FontType
FontList()\PitchAndFamily = *lpelfex\elfLogFont\lfPitchAndFamily
FontList()\ScriptList$ = ScriptList$
FontList()\ntmFlags = *lpntm\ntmFlags
FontList()\MainFontName$ = ""
FontList()\Variants$ = ""
Else
FontList()\ScriptList$ + ", " + PeekS(@*lpelfex\elfScript[0])
EndIf
If *lpntm\tmWeight >= 600
FontList()\ntmFlags | #NTM_BOLD
EndIf
EndIf
EndIf
EndIf
EndIf
EndIf
EndIf
ProcedureReturn 1
EndProcedure
;
Procedure ZFR_ListFonts(Window, FontListGadget, Options)
;
Protected PosInList, Pos, Indic$, PPos, MMainFontName$, VariantList$, Variant$
Shared FontList()
;
Protected VariantIndicators$ = "Extra,Semi,Demi,Light,Med,Bold,Black,Heavy,Ultra,Cond,Italic,SmBd,Bd,Cn,Bk,Blk,Hv,Lt,Md,XBlk,Thin"
If Window
If IsWindow(Window)
Window = WindowID(Window)
EndIf
;
Protected hdc = GetDC_(Window)
If hdc
ClearList(FontList())
EnumFontFamiliesEx_(hdc, 0, @ZFR_EnumFontProc(), Options, 0)
SortStructuredList(FontList(), #PB_Sort_Ascending, OffsetOf(FontInfoStruct\FontName$), TypeOf(FontInfoStruct\FontName$))
ForEach(FontList())
PosInList = 0
Pos = 0
Repeat
PosInList + 1
Indic$ = StringField(VariantIndicators$, PosInList, ",")
If Indic$
PPos = FindString(FontList()\FontName$, Indic$)
If PPos And (PPos < Pos Or Pos = 0)
Pos = PPos
EndIf
EndIf
Until Indic$ = ""
If Pos > 1
FontList()\MainFontName$ = Trim(Left(FontList()\FontName$, Pos -1))
Else
FontList()\MainFontName$ = FontList()\FontName$
EndIf
;
Next
SortStructuredList(FontList(), #PB_Sort_Ascending, OffsetOf(FontInfoStruct\MainFontName$), TypeOf(FontInfoStruct\MainFontName$))
MMainFontName$ = ""
ForEach(FontList())
If FontList()\MainFontName$ <> MMainFontName$
MMainFontName$ = FontList()\MainFontName$
AddGadgetItem(FontListGadget, -1, MMainFontName$)
VariantList$ = ""
Protected *Main = @FontList()
While FontList()\MainFontName$ = MMainFontName$
Variant$ = Trim(Mid(FontList()\FontName$, Len(FontList()\MainFontName$) + 1))
If Variant$ = ""
Variant$ = "Normal"
EndIf
VariantList$ + Variant$ + ","
FontList()\Variants$ = Variant$
If NextElement(FontList()) = 0
MMainFontName$ = ""
EndIf
Wend
Protected *LastFLE = @FontList()
ChangeCurrentElement(FontList(), *Main)
FontList()\Variants$ = VariantList$
ChangeCurrentElement(FontList(), *LastFLE)
If MMainFontName$
PreviousElement(FontList())
EndIf
EndIf
;
Next
ReleaseDC_(Window, hDC)
EndIf
EndIf
EndProcedure
;
Procedure.s ZFR_GetFontInfosText()
;
Shared FontList()
Protected FontInfos$, tm.TEXTMETRIC
;
FontInfos$ = GetTextFromCatalog("Name:") + " " + FontList()\FontName$ + #CR$
FontInfos$ + GetTextFromCatalog("Type:") + " " + ZFR_GetFontTypeNameFromNum(FontList()\FontType) + " - "
FontInfos$ + GetTextFromCatalog("Family:") + " " + ZFR_GetFontFamilyNameFromNum(FontList()\PitchAndFamily) + " - "
FontInfos$ + GetTextFromCatalog("Style:") + " " + FontList()\FontStyle$ + #CR$
FontInfos$ + GetTextFromCatalog("Script(s):") + " " + FontList()\ScriptList$ + #CR$
;
Protected Font = LoadFont(#PB_Any, FontList()\FontName$, 48)
Protected hDC = GetDC_(0)
SelectObject_(hDC, FontID(Font))
GetTextMetrics_(hDC, @tm)
ReleaseDC_(0, hDC)
FreeFont(Font)
FontInfos$ + GetTextFromCatalog("Metrics:") + " Height=" + Str(tm\tmHeight/2) + ", Ascent=" + Str(tm\tmAscent/2) + ", Descent=" + Str(tm\tmDescent/2) + ", IntLeading=" + Str(tm\tmInternalLeading/2) + ", ExtLeading=" + Str(tm\tmExternalLeading/2) + ", Weight=" + Str(tm\tmWeight) + #CR$
ProcedureReturn FontInfos$
EndProcedure
;
Procedure.s ZFR_RetreiveFontListElementFromGadgets(ZFR_CFont, ZFR_CBVariants, CFontOnly = #False, itemNumCFont = -1, itemNumCBVariants = -1)
;
Protected Found = 0, FontName$, Variant$
Shared FontList()
;
If itemNumCFont = -1 : itemNumCFont = GetGadgetState(ZFR_CFont) : EndIf
If itemNumCBVariants = -1 : itemNumCBVariants = GetGadgetState(ZFR_CBVariants) : EndIf
;
FontName$ = GetGadgetItemText(ZFR_CFont, itemNumCFont)
;
ForEach FontList()
If Left(FontList()\MainFontName$, Len(FontName$)) = FontName$
If CFontOnly
Found = 1
Else
Protected *Main = @FontList()
While FontList()\MainFontName$ = FontName$
Variant$ = Trim(Mid(FontList()\FontName$, Len(FontName$) + 1))
If Variant$ = ""
Variant$ = "Normal"
EndIf
If Variant$ = GetGadgetItemText(ZFR_CBVariants, itemNumCBVariants)
Found = 1
Break
EndIf
NextElement(FontList())
Wend
EndIf
Break
EndIf
Next
If Found = 0 And *Main
ChangeCurrentElement(FontList(), *Main)
EndIf
ProcedureReturn FontList()\FontName$
EndProcedure
;
Procedure ZFR_ApplyFontToExample(ZFR_CFont, ZFR_CBVariants, SSize, CBBold, CBItalic, CBUnderline, CBStrikeOut, FontColor, TExample, TDetails, DetailsToggle)
;
Shared FontList()
Static mItalicState = -1, mBoldState = -1, TextFont
Protected FontStyle = 0
;
ZFR_RetreiveFontListElementFromGadgets(ZFR_CFont, ZFR_CBVariants)
;
If IsGadget(CBItalic)
If FontList()\ntmFlags & #NTM_ITALIC
mItalicState = GetGadgetState(CBItalic)
SetGadgetState(CBItalic, 1)
DisableGadget(CBItalic, #True)
Else
If mItalicState <> -1
SetGadgetState(CBItalic, mItalicState)
mItalicState = -1
EndIf
DisableGadget(CBItalic, #False)
EndIf
EndIf
;
If IsGadget(CBBold)
If FontList()\ntmFlags & #NTM_BOLD
mBoldState = GetGadgetState(CBBold)
SetGadgetState(CBBold, 1)
DisableGadget(CBBold, #True)
Else
If mBoldState <> -1
SetGadgetState(CBBold, mBoldState)
mBoldState = -1
EndIf
DisableGadget(CBBold, #False)
EndIf
EndIf
;
If IsGadget(CBBold) And GetGadgetState(CBBold)
FontStyle | #PB_Font_Bold
EndIf
If IsGadget(CBItalic) And GetGadgetState(CBItalic)
FontStyle | #PB_Font_Italic
EndIf
If IsGadget(CBUnderline) And GetGadgetState(CBUnderline)
FontStyle | #PB_Font_Underline
EndIf
If IsGadget(CBStrikeOut) And GetGadgetState(CBStrikeOut)
FontStyle | #PB_Font_StrikeOut
EndIf
;
If IsFont(TextFont)
FreeFont(TextFont)
EndIf
If IsGadget(SSize)
Size = Val(GetGadgetText(SSize))
Else
Size = 10
EndIf
TextFont = LoadFont(#PB_Any, FontList()\FontName$, Size, FontStyle)
SetGadgetFont(TExample, FontID(TextFont))
;
If FontColor = -1
CompilerIf Defined(SetGadgetsColorsFromTheme, #PB_Procedure)
If ListSize(InterfaceColorPresets()) > 0
FontColor = GetRealColorFromType("TextColor", InterfaceColorPresets()\TextColor)
Else
FontColor = 0
EndIf
CompilerElseIf Defined(ObjectTheme, #PB_Module)
; Manage compatibility with the ObjectTheme.pbi library:
FontColor = ObjectTheme::GetObjectThemeAttribute(#PB_GadgetType_Button, #PB_Gadget_FrontColor)
CompilerElse
FontColor = 0
CompilerEndIf
EndIf
SetGadgetColor(TExample, #PB_Gadget_FrontColor, FontColor)
;
If DetailsToggle
SetGadgetText(TDetails, ZFR_GetFontInfosText())
EndIf
EndProcedure
;
Macro ZFR_ExtractParametersFromFontDescription(FontDescription)
;
FontColor = -1
pp = FindString(LCase(FontDescription), "rgb")
If pp
mpp = pp
pp + 3
While Mid(FontDescription, pp, 1) = " "
pp + 1
Wend
If Mid(FontDescription, pp, 1) = "("
pp + 1
pp2 = FindString(FontDescription, ")", pp)
If pp2
RGBColor$ = Mid(FontDescription, pp, pp2 - pp)
FontColor = RGB(Val(StringField(RGBColor$, 1, ",")), Val(StringField(RGBColor$, 2, ",")), Val(StringField(RGBColor$, 3, ",")))
pp2 + 1
While Mid(FontDescription, pp2, 1) = ")" Or Mid(FontDescription, pp2, 1) = "," Or Mid(FontDescription, pp2, 1) = " "
pp2 + 1
Wend
FontDescription = Left(FontDescription, mpp - 1) + Mid(FontDescription, pp2)
EndIf
EndIf
EndIf
ct = 1
Repeat
Param$ = StringField(FontDescription, ct, ",")
If Param$
PType$ = ""
pp = FindString(Param$, ":")
If pp = 0 : pp = FindString(Param$, "(") : EndIf
If pp
PType$ = Trim(LCase(Left(Param$, pp - 1)))
Param$ = Trim(ReplaceString(Mid(Param$, pp + 1), ")", ""))
EndIf
If FindString(PType$, "name") Or (PType$ = "" And ct = 1)
FontName$ = Param$
ElseIf FindString(PType$, "size") Or (PType$ = "" And ct = 2)
FontSize = ValF(Param$)
If FontSize = 0
FontSize = Val(Param$)
EndIf
ElseIf (FindString(PType$, "color") Or (PType$ = "" And ct = 3)) And FontColor = -1 And FindString(PType$, "backcolor") = 0
If Left(Param$, 2) = "0x" And Val("$" + Mid(Param$, 3))
FontColor = Val("$" + Mid(Param$, 3))
ElseIf Val(Param$) = 0 And Val("$" + Param$)
FontColor = Val("$" + Param$)
ElseIf Str(Val(Param$)) = Param$ Or FindString(PType$, "color") Or Param$ = "$0"
FontColor = Val(Param$)
EndIf
EndIf
EndIf
ct + 1
Until Param$ = ""
If FontName$ = "" : FontName$ = "Segoe UI" : EndIf
If FontSize = 0 : FontSize = 9 : EndIf
FontStyle = GetNumStyleFromAttributesDescription(FontDescription)
EndMacro
;
Procedure ZFR_UpdateCBVariantsFromCFont(ZFR_CFont, ZFR_CBVariants)
;
Shared FontList()
Protected Pos, Variant$
;
ForEach(FontList())
If FontList()\MainFontName$ = GetGadgetText(ZFR_CFont)
Break
EndIf
Next
;
ClearGadgetItems(ZFR_CBVariants)
Pos = 0
Repeat
Pos + 1
Variant$ = StringField(FontList()\Variants$, Pos, ",")
If Variant$
AddGadgetItem(ZFR_CBVariants, -1, Variant$)
EndIf
Until Variant$ = ""
;
SetGadgetState(ZFR_CBVariants, 0)
If CountGadgetItems(ZFR_CBVariants) < 2
DisableGadget(ZFR_CBVariants, #True)
Else
DisableGadget(ZFR_CBVariants, #False)
EndIf
InvalidateRect_(GadgetID(ZFR_CBVariants), 0, #True)
EndProcedure
;
Global ZFR_CFont, ZFR_CBVariants
;
Procedure.i ZFR_OwnerDrawCallback(hWnd, uMsg, wParam, lParam)
Shared FontList()
Protected *drawItem.DRAWITEMSTRUCT, HighLight = 0
Protected hDC, rc.RECT, rcBack.RECT, Text$, DSize.Size, Font, Size, Height
Protected itemNum, ODTType, hBrush, FontName$, NFontName$
Protected tm.TEXTMETRIC
;
Select uMsg
Case #WM_MEASUREITEM
Protected *measureItem.MEASUREITEMSTRUCT = lParam
;
ODTType = *measureItem\CtlType
If ODTType = #ODT_COMBOBOX
*measureItem\itemHeight = DesktopScaledY(20)
ProcedureReturn #True
EndIf
Case #WM_DRAWITEM
*drawItem = lParam
itemNum = *drawItem\itemID
Protected CtlID = GetProp_(*drawItem\hwndItem, "PB_ID")
If (CtlID = ZFR_CFont Or CtlID = ZFR_CBVariants) And itemNum > -1
;
hDC = *drawItem\hdc
rc = *drawItem\rcItem
CopyStructure(rc, rcBack, RECT)
ODTType = *drawItem\CtlType
;
If ODTType = #ODT_COMBOBOX And (*drawItem\rcItem\bottom - *drawItem\rcItem\top) < SendMessage_(*drawItem\hwndItem, #CB_GETITEMHEIGHT, 0, 0)
Protected DrawingComboTitle = 1
EndIf
;
If *drawItem\itemState & #ODS_SELECTED
If ODTType = #ODT_COMBOBOX
If DrawingComboTitle = 0
HighLight = 1
EndIf
Else
HighLight = 1
EndIf
EndIf
If HighLight
Protected BackColor = GetSysColor_(#COLOR_HIGHLIGHT)
Protected TextColor = GetSysColor_(#COLOR_HIGHLIGHTTEXT)
SetTextColor_(hDC, TextColor)
Else
BackColor = GetSysColor_(#COLOR_WINDOW)
TextColor = GetSysColor_(#COLOR_WINDOWTEXT)
If DrawingComboTitle = 0
CompilerIf Defined(SetGadgetsColorsFromTheme, #PB_Procedure)
If ListSize(InterfaceColorPresets()) > 0
BackColor = GetRealColorFromType("BackgroundColor", InterfaceColorPresets()\BackgroundColor)
TextColor = GetRealColorFromType("TextColor", InterfaceColorPresets()\TextColor)
EndIf
CompilerEndIf
EndIf
CompilerIf Defined(ObjectTheme, #PB_Module)
BackColor = ObjectTheme::GetObjectThemeAttribute(0, #PB_Gadget_BackColor)
TextColor = ObjectTheme::GetObjectThemeAttribute(#PB_GadgetType_Button, #PB_Gadget_FrontColor)
CompilerEndIf
SetTextColor_(hDC, TextColor)
EndIf
;
hBrush = CreateSolidBrush_(BackColor)
If ODTType = #ODT_COMBOBOX
rcBack\left - 1 : rcBack\top - 1 : rcBack\right + 1 : rcBack\bottom + 1
SelectClipRgn_(hDC, 0)
EndIf
;
FillRect_(hDC, @rcBack, hBrush)
DeleteObject_(hBrush)
;
rc\left + DesktopScaledY(2)
Text$ = GetGadgetItemText(CtlID, itemNum)
;
If CtlID = ZFR_CFont
FontName$ = ZFR_RetreiveFontListElementFromGadgets(ZFR_CFont, ZFR_CBVariants, #True, itemNum, -1)
Else
FontName$ = ZFR_RetreiveFontListElementFromGadgets(ZFR_CFont, ZFR_CBVariants, #False, -1, itemNum)
EndIf
If FontList()\ScriptList$ = "Symbole"
NFontName$ = "Segoe UI"
Else
NFontName$ = FontName$
EndIf
Size = DesktopScaledY(10)
Font = LoadFont(#PB_Any, NFontName$, Size)
SelectObject_(hDC, FontID(Font))
GetTextMetrics_(hDC, @tm.TEXTMETRIC)
FreeFont(Font)
;
If (tm\tmInternalLeading + tm\tmExternalLeading) < tm\tmHeight / 4
tm\tmInternalLeading = tm\tmHeight / 4
EndIf
;
Height = tm\tmHeight - tm\tmInternalLeading
Size = Round(Size * DesktopScaledY(12) / Height, #PB_Round_Nearest)
;
Font = LoadFont(#PB_Any, NFontName$, Size)
SelectObject_(hDC, FontID(Font))
SetBkMode_(hDC, #TRANSPARENT)
DrawText_(hDC, Text$, Len(Text$), @rc, #DT_LEFT | #DT_VCENTER | #DT_SINGLELINE)
;
If CtlID = ZFR_CFont And FontList()\ScriptList$ = "Symbole"
GetTextExtentPoint32_(hDC, Text$, Len(Text$), @DSize)
rc\left + DSize\cx + DesktopScaledX(8)
FreeFont(Font)
Font = LoadFont(#PB_Any, FontName$, Size)
SelectObject_(hDC, FontID(Font))
DrawText_(hDC, "Aaz1", Len("Aaz1"), @rc, #DT_LEFT | #DT_VCENTER | #DT_SINGLELINE)
EndIf
;
FreeFont(Font)
;
ProcedureReturn #True
EndIf
EndSelect
;
Protected ZFR_OldCallBack = GetProp_(hWnd, "ZFR_OldCallBack")
ProcedureReturn CallWindowProc_(ZFR_OldCallBack, hWnd, uMsg, wParam, lParam)
EndProcedure
;
; ****************************************************************************
;
;- 4. Zapman FontRequester public functions
;
; ****************************************************************************
;
Procedure.s FontRequesterEx(FontDescription$, AvailableStyles = #ZFR_FontRequester_Default, ParentID = #PB_Default, XShiftOrPos = 0, YShiftOrPos = 0, *UserChoice.Integer = 0)
;
If AvailableStyles = -1
AvailableStyles = #ZFR_FontRequester_Effects
EndIf
;
Protected ParentWindow = #PB_Default
If IsWindow(ParentID)
ParentWindow = ParentID
ParentID = WindowID(ParentID)
ElseIf ParentID <> #PB_Default And IsWindow_(ParentID)
ParentWindow = GetProp_(ParentID, "PB_WindowID") - 1
ElseIf IsWindow(GetActiveWindow()) And ParentID = #PB_Default
ParentWindow = GetActiveWindow()
ParentID = WindowID(ParentWindow)
EndIf
If ParentWindow = #PB_Default
ParentWindow = ParentID
EndIf
;
Shared FontList()
;
Protected Param$, PType$, FontName$, FontSize$, FontSize.f, FontColor, FontStyle
Protected pp, ct, Event, EventGadget, Gadget, GetOut, OX, OY
Protected mpp, pp2, RGBColor$, BSizePlus, BSizeMinus, BVariantState, NFontColor
Protected CFontState, Found, Windowskey
;
Protected mFontDescription$ = FontDescription$
FontDescription$ = LCase(FontDescription$)
;
Protected DetailsToggle = 0
;
ZFR_ExtractParametersFromFontDescription(FontDescription$)
;
Protected TextFont = LoadFont(#PB_Any, FontName$, FontSize, FontStyle)
;
FontName$ = GetFontName(TextFont)
FreeFont(TextFont)
;
Protected WWidth = 480
Protected WHeight = 230
Protected Margins = 10
Protected Intergadget = 7
Protected LineHeight = 22
Protected NbStyles = 0
;
If AvailableStyles & #PB_Font_Bold
NbStyles + 1
EndIf
If AvailableStyles & #PB_Font_Italic
NbStyles + 1
EndIf
If AvailableStyles & #PB_Font_StrikeOut
NbStyles + 1
EndIf
If AvailableStyles & #PB_Font_Underline
NbStyles + 1
EndIf
If AvailableStyles & #ZFR_ChooseColor
NbStyles + 1
EndIf
If AvailableStyles & #ZFR_ShowSize
NbStyles + 1
EndIf
WHeight + ((LineHeight + Intergadget) * (NbStyles - 1)) / 2
If WHeight < 240 : WHeight = 240 : EndIf
;
Protected WParam = #PB_Window_SystemMenu | #PB_Window_Invisible
Protected ParentWindowID = ComputeWinOrigins(@OX, @OY, WWidth, WHeight, ParentWindow, XShiftOrPos, YShiftOrPos)
Protected CFWindow = OpenWindow(#PB_Any, OX, OY, WWidth, WHeight, GetTextFromCatalog("ChooseAFont"), WParam, ParentWindowID)
If CFWindow
If IsWindow(ParentWindow) And IsWindowEnabled_(WindowID(ParentWindow))
DisableWindow(ParentWindow, #True)
Protected ParentHasBeenDisabled = #True
EndIf
Protected ZFR_OldCallback = SetWindowLongPtr_(WindowID(CFWindow), #GWL_WNDPROC, @ZFR_OwnerDrawCallback())
SetProp_(WindowID(CFWindow), "ZFR_OldCallback", ZFR_OldCallback)
;
CompilerIf Defined(ApplyDarkModeToWindow, #PB_Procedure)
ApplyDarkModeToWindow(CFWindow)
CompilerEndIf
;
StickyWindow(CFWindow, #True)
;
Protected LegendWidth = 65
Protected FontListWidth = 200
Protected DetailsHeight = 90
Protected UsableHeight = WindowHeight(CFWindow) - Margins * 2
Protected SFont = StringGadget(#PB_Any, Margins, Margins, FontListWidth, LineHeight, "")
Protected GadgetList$ = Str(SFont) + ","
;
ZFR_CFont = ListViewGadget(#PB_Any, Margins, Margins + LineHeight + Intergadget, FontListWidth, UsableHeight - LineHeight - Intergadget - 1, #LBS_OWNERDRAWFIXED) ; List of fonts
SendMessage_(GadgetID(ZFR_CFont), #LB_SETITEMHEIGHT, -1, DesktopScaledX(20))
GadgetList$ + Str(ZFR_CFont) + ","
;
Protected VPos = Margins
Protected HPos = Margins + FontListWidth + Margins
Protected TVariants = TextGadget(#PB_Any, HPos, VPos + 2, LegendWidth, LineHeight, GetTextFromCatalog("Variants:"), #PB_Text_Right)
GadgetList$ + Str(TVariants) + ","
;
HPos + LegendWidth + Intergadget
Protected GWidth = WindowWidth(CFWindow) - Margins - HPos
;
ZFR_CBVariants = ComboBoxGadget(#PB_Any, HPos, VPos, GWidth, LineHeight, #CBS_OWNERDRAWFIXED | #CBS_HASSTRINGS) ; List of variants
GadgetList$ + Str(ZFR_CBVariants) + ","
;
Protected HPos2 = Margins + FontListWidth + Margins
Protected CBWidth = 90
Protected CBPosLeft = HPos;2 + 40
VPos + LineHeight + 3
HPos = CBPosLeft
;
If AvailableStyles & #PB_Font_Bold
Protected CBBold = CheckBoxGadget(#PB_Any, HPos, VPos, CBWidth, LineHeight, GetTextFromCatalog("Bold"))
GadgetList$ + Str(CBBold) + ","
If FontStyle & #PB_Font_Bold
SetGadgetState(CBBold, #True)
EndIf
If HPos = CBPosLeft
HPos + CBWidth
Else
HPos = CBPosLeft
VPos + LineHeight - 2
EndIf
Else
FontStyle & ~(#PB_Font_Bold)
EndIf
;
If AvailableStyles & #PB_Font_Italic
Protected CBItalic = CheckBoxGadget(#PB_Any, HPos, VPos, CBWidth, LineHeight, GetTextFromCatalog("Italic"))
GadgetList$ + Str(CBItalic) + ","
If FontStyle & #PB_Font_Italic
SetGadgetState(CBItalic, #True)
EndIf
If HPos = CBPosLeft
HPos + CBWidth
Else
HPos = CBPosLeft
VPos + LineHeight - 2
EndIf
Else
FontStyle & ~(#PB_Font_Italic)
EndIf
;
If AvailableStyles & #PB_Font_Underline
Protected CBUnderline = CheckBoxGadget(#PB_Any, HPos, VPos, CBWidth, LineHeight, GetTextFromCatalog("Underline"))
GadgetList$ + Str(CBUnderline) + ","
If FontStyle & #PB_Font_Underline
SetGadgetState(CBUnderline, #True)
EndIf
If HPos = CBPosLeft
HPos + CBWidth
Else
HPos = CBPosLeft
VPos + LineHeight - 2
EndIf
Else
FontStyle & ~(#PB_Font_Underline)
EndIf
;
If AvailableStyles & #PB_Font_StrikeOut
Protected CBStrikeOut = CheckBoxGadget(#PB_Any, HPos, VPos, GWidth, LineHeight, GetTextFromCatalog("StrikeOut"))
GadgetList$ + Str(CBStrikeOut) + ","
If FontStyle & #PB_Font_StrikeOut
SetGadgetState(CBStrikeOut, #True)
EndIf
If HPos = CBPosLeft
HPos + CBWidth
Else
HPos = CBPosLeft
VPos + LineHeight - 2
EndIf
Else
FontStyle & ~(#PB_Font_StrikeOut)
EndIf
;
If HPos <> CBPosLeft
VPos + LineHeight - 2
EndIf
HPos = HPos2
VPos + 5
;
If AvailableStyles & #ZFR_ShowSize
Protected TSize = TextGadget(#PB_Any, HPos, VPos + 2, LegendWidth, LineHeight, GetTextFromCatalog("Size:"), #PB_Text_Right)
GadgetList$ + Str(TSize) + ","
HPos + LegendWidth + Intergadget
Protected SSize = SpinGadget(#PB_Any, HPos, VPos, 45, LineHeight, 1, 500, #PB_Spin_Numeric) ; Font size
SetWindowLongPtr_(GadgetID(SSize), #GWL_STYLE, GetWindowLongPtr_(GadgetID(SSize), #GWL_STYLE) | #ES_NUMBER)
GadgetList$ + Str(SSize) + ","
SetGadgetText(SSize, StrF(FontSize))
HPos + 45
EndIf
;
If AvailableStyles & #ZFR_ChooseColor
Protected TColor = TextGadget(#PB_Any, HPos, VPos + 2, LegendWidth, LineHeight, GetTextFromCatalog("Color:"), #PB_Text_Right)
GadgetList$ + Str(TColor) + ","
HPos + LegendWidth + Intergadget
Protected CanvasColor = CanvasGadget(#PB_Any, HPos, VPos, LineHeight, LineHeight)
GadgetList$ + Str(CanvasColor) + ","
If StartDrawing(CanvasOutput(CanvasColor))
DrawingMode(#PB_2DDrawing_Default)
Box(0, 0, 300, 200, FontColor)
StopDrawing()
EndIf
Else
FontStyle & ~(#ZFR_ChooseColor)
EndIf
;
HPos = HPos2
If AvailableStyles & #ZFR_ShowSize Or AvailableStyles & #ZFR_ChooseColor
VPos + LineHeight + Margins + Intergadget
Else
VPos + 3
EndIf
Protected FExample = FrameGadget(#PB_Any, HPos, VPos - Margins, WindowWidth(CFWindow) - Margins - HPos, UsableHeight + 2 *Margins - LineHeight - Intergadget - VPos, GetTextFromCatalog("Sample"))
GadgetList$ + Str(FExample) + ","
Protected TExample = TextGadget(#PB_Any, HPos + Margins, VPos + Margins, WindowWidth(CFWindow) - 3 * Margins - HPos, UsableHeight - 3 - LineHeight - Intergadget - VPos, GetTextFromCatalog("CAFDemoText"), #PB_Text_Center)
;
VPos = UsableHeight + Margins - LineHeight
;
Protected TDetails = TextGadget(#PB_Any, Margins, VPos, WindowWidth(CFWindow) - 2 * Margins, DetailsHeight, "")
GadgetList$ + Str(TDetails) + ","
HideGadget(TDetails, #True)
;
HPos = HPos2
Protected BCancelWidth = 75
Protected BDetailsWidth = 100
Protected BOKWidth = 60
Protected BDetails = ButtonGadget(#PB_Any, HPos, VPos, BDetailsWidth, LineHeight, GetTextFromCatalog("DetailsDwn")) ; Bouton Annuler
GadgetList$ + Str(BDetails) + ","
HPos + BDetailsWidth + Intergadget
Protected BCancel = ButtonGadget(#PB_Any, HPos, VPos, BCancelWidth, LineHeight, GetTextFromCatalog("Cancel")) ; Bouton Annuler
GadgetList$ + Str(BCancel) + ","
Protected BOK = ButtonGadget(#PB_Any, WindowWidth(CFWindow) - Margins - BOKWidth, VPos, BOKWidth, LineHeight, GetTextFromCatalog("OK"), #PB_Button_Default) ; Bouton OK
GadgetList$ + Str(BOK) + ","
;
ZFR_ListFonts(CFWindow, ZFR_CFont, AvailableStyles)
;
If CountGadgetItems(ZFR_CFont) = 0
If ParentHasBeenDisabled
DisableWindow(ParentWindow, #False)
EndIf
ProcedureReturn FontDescription$
EndIf
;
Protected mLen = 0
For ct = 0 To CountGadgetItems(ZFR_CFont)
Protected NLen = Len(GetGadgetItemText(ZFR_CFont, ct))
If NLen > mLen And GetGadgetItemText(ZFR_CFont, ct) = Left(FontName$, NLen)
SetGadgetState(ZFR_CFont, ct + 5)
SetGadgetState(ZFR_CFont, ct)
EndIf
Next
;
SetGadgetText(SFont, GetGadgetText(ZFR_CFont))
ZFR_UpdateCBVariantsFromCFont(ZFR_CFont, ZFR_CBVariants)
;
Protected Variant$ = Trim(Mid(FontName$, Len(GetGadgetText(ZFR_CFont)) + 1))
If Variant$ = ""
Variant$ = "Normal"
EndIf
;
For ct = 0 To CountGadgetItems(ZFR_CBVariants)
If Variant$ = GetGadgetItemText(ZFR_CBVariants, ct)
SetGadgetState(ZFR_CBVariants, ct)
Break
EndIf
Next
;
Protected PosInGadgetList = 0
; Set the font for all gadgets:
Repeat
PosInGadgetList + 1
Gadget = Val(StringField(GadgetList$, PosInGadgetList, ","))
If IsGadget(Gadget)
SetGadgetFont(Gadget, PBBAllGadgetsFont)
EndIf
Until StringField(GadgetList$, PosInGadgetList, ",") = ""
CompilerIf Defined(SetGadgetsColorsFromTheme, #PB_Procedure)
;
If ListSize(InterfaceColorPresets()) > 0
GadgetList$ + Str(TExample) + ","
SetGadgetsColorsFromTheme(CFWindow, InterfaceColorPresets(), GadgetList$)
EndIf
;
CompilerEndIf
;
ZFR_ApplyFontToExample(ZFR_CFont, ZFR_CBVariants, SSize, CBBold, CBItalic, CBUnderline, CBStrikeOut, FontColor, TExample, TDetails, DetailsToggle)
;
Enumeration KeyboardShortCuts
#ArrowDownShortcut
#ArrowUpShortcut
#PlusShortcut
#MinusShortcut
#ZFR_Escape_Cmd
#ZFR_Enter
EndEnumeration
;
AddKeyboardShortcut(CFWindow, #PB_Shortcut_Down, #ArrowDownShortcut)
AddKeyboardShortcut(CFWindow, #PB_Shortcut_Up, #ArrowUpShortcut)
AddKeyboardShortcut(CFWindow, #PB_Shortcut_Add, #PlusShortcut)
AddKeyboardShortcut(CFWindow, #PB_Shortcut_Subtract, #MinusShortcut)
AddKeyboardShortcut(CFWindow, #PB_Shortcut_6, #MinusShortcut)
AddKeyboardShortcut(CFWindow, #PB_Shortcut_Escape, #ZFR_Escape_Cmd)
AddKeyboardShortcut(CFWindow, #PB_Shortcut_Return, #ZFR_Enter)
HideWindow(CFWindow, #False)
;
SetActiveGadget(SFont)
;
Repeat
Event = WaitWindowEvent()
EventGadget = EventGadget()
If Event = #PB_Event_Menu
If EventMenu() = #ArrowDownShortcut Or EventMenu() = #ArrowUpShortcut
If GetActiveGadget() = SSize Or GetActiveGadget() = BSizePlus Or GetActiveGadget() = BSizeMinus
If EventMenu() = #ArrowUpShortcut
Event = #PB_Event_Gadget
EventGadget = BSizePlus
Else
Event = #PB_Event_Gadget
EventGadget = BSizeMinus
EndIf
ElseIf GetActiveGadget() = ZFR_CBVariants
BVariantState = GetGadgetState(ZFR_CBVariants)
If EventMenu() = #ArrowUpShortcut And BVariantState > 0
SetGadgetState(ZFR_CBVariants, BVariantState - 1)
ZFR_ApplyFontToExample(ZFR_CFont, ZFR_CBVariants, SSize, CBBold, CBItalic, CBUnderline, CBStrikeOut, FontColor, TExample, TDetails, DetailsToggle)
ElseIf EventMenu() = #ArrowDownShortcut And BVariantState < CountGadgetItems(ZFR_CBVariants) - 1
SetGadgetState(ZFR_CBVariants, BVariantState + 1)
ZFR_ApplyFontToExample(ZFR_CFont, ZFR_CBVariants, SSize, CBBold, CBItalic, CBUnderline, CBStrikeOut, FontColor, TExample, TDetails, DetailsToggle)
EndIf
Else
If GetActiveGadget() = SFont Or GetActiveGadget() = BDetails
SetActiveGadget(ZFR_CFont)
EndIf
Gadget = GetActiveGadget()
If Gadget = -1
Gadget = ZFR_CFont
EndIf
CFontState = GetGadgetState(Gadget)
If EventMenu() = #ArrowDownShortcut And CFontState < (CountGadgetItems(Gadget) - 1)
SetGadgetState(Gadget, CFontState + 1)
ElseIf EventMenu() = #ArrowUpShortcut And CFontState > 0
SetGadgetState(Gadget, CFontState - 1)
EndIf
ZFR_UpdateCBVariantsFromCFont(ZFR_CFont, ZFR_CBVariants)
SetGadgetText(SFont, GetGadgetText(ZFR_CFont))
ZFR_ApplyFontToExample(ZFR_CFont, ZFR_CBVariants, SSize, CBBold, CBItalic, CBUnderline, CBStrikeOut, FontColor, TExample, TDetails, DetailsToggle)
EndIf
ElseIf EventMenu() = #PlusShortcut
Event = #PB_Event_Gadget
EventGadget = #PlusShortcut
ElseIf EventMenu() = #MinusShortcut
Event = #PB_Event_Gadget
EventGadget = #MinusShortcut
ElseIf EventMenu() = #ZFR_Escape_Cmd
Event = #PB_Event_Gadget
EventGadget = BCancel
ElseIf EventMenu() = #ZFR_Enter
If GetActiveGadget() = ZFR_CBVariants
; Select the actual line and close the gadget.
DisableGadget(ZFR_CBVariants, #True)
DisableGadget(ZFR_CBVariants, #False)
SetActiveGadget(ZFR_CBVariants)
Else
Event = #PB_Event_Gadget
EventGadget = BOk
EndIf
EndIf
EndIf
CompilerIf #PB_Compiler_OS = #PB_OS_Windows
If GetAsyncKeyState_(#VK_OEM_PLUS) & $8000
If Windowskey <> #VK_OEM_PLUS
Windowskey = #VK_OEM_PLUS
EventGadget = #PlusShortcut
Event = #PB_Event_Gadget
EndIf
ElseIf GetAsyncKeyState_(#VK_OEM_MINUS) & $8000
If Windowskey <> #VK_OEM_MINUS
Windowskey = #VK_OEM_MINUS
EventGadget = #MinusShortcut
Event = #PB_Event_Gadget
EndIf
Else
Windowskey = 0
EndIf
CompilerEndIf
Select Event
Case #PB_Event_Gadget
Select EventGadget
Case BDetails
If DetailsToggle = 0
DetailsToggle = 1
SetGadgetText(BDetails, GetTextFromCatalog("DetailsUp"))
ResizeWindow(CFWindow, #PB_Ignore, #PB_Ignore, #PB_Ignore, WindowHeight(CFWindow) + DetailsHeight)
ResizeGadget(ZFR_CFont, #PB_Ignore, #PB_Ignore, #PB_Ignore, GadgetHeight(ZFR_CFont) - LineHeight - Intergadget)
HideGadget(TDetails, #False)
ZFR_ApplyFontToExample(ZFR_CFont, ZFR_CBVariants, SSize, CBBold, CBItalic, CBUnderline, CBStrikeOut, FontColor, TExample, TDetails, DetailsToggle)
SetGadgetText(TDetails, ZFR_GetFontInfosText())
SetGadgetState(ZFR_CFont, GetGadgetState(ZFR_CFont) + 5)
SetGadgetState(ZFR_CFont, GetGadgetState(ZFR_CFont))
Else
DetailsToggle = 0
SetGadgetText(BDetails, GetTextFromCatalog("DetailsDwn"))
ResizeWindow(CFWindow, #PB_Ignore, #PB_Ignore, #PB_Ignore, WindowHeight(CFWindow) - DetailsHeight)
ResizeGadget(ZFR_CFont, #PB_Ignore, #PB_Ignore, #PB_Ignore, GadgetHeight(ZFR_CFont) + LineHeight + Intergadget)
HideGadget(TDetails, #True)
EndIf
VPos = WindowHeight(CFWindow) - Margins - LineHeight
ResizeGadget(BDetails, #PB_Ignore, VPos, #PB_Ignore, #PB_Ignore)
ResizeGadget(BCancel, #PB_Ignore, VPos, #PB_Ignore, #PB_Ignore)
ResizeGadget(BOk, #PB_Ignore, VPos, #PB_Ignore, #PB_Ignore)
Case SFont
If EventType() = #PB_EventType_Change
FontName$ = LCase(GetGadgetText(SFont))
Found = -1
For ct = 0 To CountGadgetItems(ZFR_CFont) -1
If LCase(Left(GetGadgetItemText(ZFR_CFont, ct), Len(FontName$))) = FontName$
Found = ct
SetGadgetState(ZFR_CFont, ct + 5)
SetGadgetState(ZFR_CFont, ct)
ZFR_UpdateCBVariantsFromCFont(ZFR_CFont, ZFR_CBVariants)
ZFR_ApplyFontToExample(ZFR_CFont, ZFR_CBVariants, SSize, CBBold, CBItalic, CBUnderline, CBStrikeOut, FontColor, TExample, TDetails, DetailsToggle)
Break
EndIf
Next
If Found = -1
SetGadgetText(SFont, Left(FontName$, Len(FontName$) - 1))
CompilerIf #PB_Compiler_OS = #PB_OS_Windows
SendMessage_(GadgetID(SFont), #EM_SETSEL, Len(FontName$) - 1, Len(FontName$) - 1)
CompilerEndIf
EndIf
ElseIf EventType() = #PB_EventType_Focus
CompilerIf #PB_Compiler_OS = #PB_OS_Windows
SendMessage_(GadgetID(SFont), #EM_SETSEL, 0, -1)
CompilerEndIf
EndIf
Case ZFR_CFont, SSize, ZFR_CBVariants, CBBold, CBItalic, CBUnderline, CBStrikeOut, #PlusShortcut, #MinusShortcut
If EventGadget = #PlusShortcut
FontSize$ = StrF(ValF(GetGadgetText(SSize)) + 1)
SetGadgetText(SSize, FontSize$)
ElseIf EventGadget = #MinusShortcut
FontSize$ = StrF(ValF(GetGadgetText(SSize)) - 1)
If ValF(FontSize$) < 0 : FontSize$ = "0" : EndIf
SetGadgetText(SSize, FontSize$)
EndIf
;
If EventGadget = ZFR_CFont
ZFR_UpdateCBVariantsFromCFont(ZFR_CFont, ZFR_CBVariants)
EndIf
ZFR_ApplyFontToExample(ZFR_CFont, ZFR_CBVariants, SSize, CBBold, CBItalic, CBUnderline, CBStrikeOut, FontColor, TExample, TDetails, DetailsToggle)
;
SetGadgetText(SFont, GetGadgetText(ZFR_CFont))
;
Case CanvasColor
If EventType() = #PB_EventType_LeftButtonDown
CompilerIf Defined(ZapmanColorRequester, #PB_Procedure)
NFontColor = ZapmanColorRequester(FontColor, -1, -1, WindowID(CFWindow))
CompilerElse
NFontColor = ColorRequester(FontColor, WindowID(CFWindow))
CompilerEndIf
If NFontColor <> -1
FontColor = NFontColor
If StartDrawing(CanvasOutput(CanvasColor))
DrawingMode(#PB_2DDrawing_Default)
Box(0, 0, 300, 200, FontColor)
StopDrawing()
EndIf
ZFR_ApplyFontToExample(ZFR_CFont, ZFR_CBVariants, SSize, CBBold, CBItalic, CBUnderline, CBStrikeOut, FontColor, TExample, TDetails, DetailsToggle)
EndIf
EndIf
Case BCancel
GetOut = -1
Break
Case BOk
GetOut = 1
Break
EndSelect
Case #PB_Event_CloseWindow
GetOut = -1
EndSelect
Until GetOut
If GetOut = 1
ZFR_RetreiveFontListElementFromGadgets(ZFR_CFont, ZFR_CBVariants)
;
FontDescription$ = FontList()\FontName$ + ", " + GetGadgetText(SSize) + ", "
If FontColor <> 0 And FontColor <> -1
FontDescription$ + "$" + Hex(FontColor) + ", "
EndIf
If IsGadget(CBBold) And GetGadgetState(CBBold) And IsWindowEnabled_(GadgetID(CBBold))
FontDescription$ + "Bold, "
EndIf
If IsGadget(CBItalic) And GetGadgetState(CBItalic) And IsWindowEnabled_(GadgetID(CBItalic))
FontDescription$ + "Italic, "
EndIf
If IsGadget(CBUnderline) And GetGadgetState(CBUnderline) And IsWindowEnabled_(GadgetID(CBUnderline))
FontDescription$ + "Underline, "
EndIf
If IsGadget(CBStrikeOut) And GetGadgetState(CBStrikeOut) And IsWindowEnabled_(GadgetID(CBStrikeOut))
FontDescription$ + "StrikeOut, "
EndIf
FontDescription$ = Left(FontDescription$, Len(FontDescription$) - 2)
; Memorize the result for the ZapmanFontColor(), ZapmanFontSize(), ZapmanFontColor() and ZapmanFontStyle() functions:
ZFR_FontDescription$ = FontDescription$
Else
GetOut = 0
FontDescription$ = mFontDescription$
EndIf
CloseWindow(CFWindow)
EndIf
;
ClearList(FontList())
;
If *UserChoice
*UserChoice\i = GetOut
EndIf
;
If ParentHasBeenDisabled
DisableWindow(ParentWindow, #False)
EndIf
ProcedureReturn FontDescription$
EndProcedure
;
Procedure ZapmanFontRequester(Police$, FontSize, Options = 0, Color = 0, FontStyle = 0, ParentID = #PB_Default, XShiftOrPos = 0, YShiftOrPos = 0)
;
Protected AvailableStyles, FontDescription$
;
If Options & #PB_FontRequester_Effects
AvailableStyles = #PB_Font_Bold | #PB_Font_Italic | #PB_Font_StrikeOut | #PB_Font_Underline | #ZFR_ChooseColor | #ZFR_ShowSize
ElseIf Options = 0
AvailableStyles = #ZFR_FontRequester_Default
Else
AvailableStyles = Options
EndIf
;
FontDescription$ = Police$ + ", " + Str(FontSize) + ", Color:" + Str(Color)
If FontStyle & #PB_Font_Italic
FontDescription$ + ", Italic"
EndIf
If FontStyle & #PB_Font_Bold
FontDescription$ + ", Bold"
EndIf
If FontStyle & #PB_Font_StrikeOut
FontDescription$ + ", StrikeOut"
EndIf
If FontStyle & #PB_Font_Underline
FontDescription$ + ", Underline"
EndIf
FontDescription$ + ","
;
Protected UserChoice
FontDescription$ = FontRequesterEx(FontDescription$, AvailableStyles, ParentID, XShiftOrPos, YShiftOrPos, @UserChoice)
ProcedureReturn UserChoice
EndProcedure
;
Procedure.s ZapmanFontName(FontDescription$ = "")
If FontDescription$ = ""
FontDescription$ = ZFR_FontDescription$
EndIf
;
Protected ct, Param$, PType$, pp, pp2, mpp, RGBColor$
Protected FontName$, FontSize, FontColor, FontStyle
;
ZFR_ExtractParametersFromFontDescription(FontDescription$)
ProcedureReturn FontName$
EndProcedure
;
Procedure ZapmanFontSize(FontDescription$ = "")
If FontDescription$ = ""
FontDescription$ = ZFR_FontDescription$
EndIf
;
Protected ct, Param$, PType$, pp, pp2, mpp, RGBColor$
Protected FontName$, FontSize, FontColor, FontStyle
;
ZFR_ExtractParametersFromFontDescription(FontDescription$)
ProcedureReturn FontSize
EndProcedure
;
Procedure ZapmanFontColor(FontDescription$ = "")
If FontDescription$ = ""
FontDescription$ = ZFR_FontDescription$
EndIf
;
Protected ct, Param$, PType$, pp, pp2, mpp, RGBColor$
Protected FontName$, FontSize, FontColor, FontStyle
;
ZFR_ExtractParametersFromFontDescription(FontDescription$)
ProcedureReturn FontColor
EndProcedure
;
Procedure ZapmanFontStyle(FontDescription$ = "")
If FontDescription$ = ""
FontDescription$ = ZFR_FontDescription$
EndIf
;
Protected ct, Param$, PType$, pp, pp2, mpp, RGBColor$
Protected FontName$, FontSize, FontColor, FontStyle
;
ZFR_ExtractParametersFromFontDescription(FontDescription$)
ProcedureReturn FontStyle
EndProcedure
;
Procedure GetFontFromDescription(FontDescription$)
Protected pp, mpp, pp2, RGBColor$, ct, Param$, PType$
Protected FontName$, FontSize, FontStyle, FontColor
;
ZFR_ExtractParametersFromFontDescription(FontDescription$)
ProcedureReturn LoadFont(#PB_Any, FontName$, FontSize, FontStyle)
EndProcedure
;
; ****************************************************************************
;
;- 5. DEMO
;
; ****************************************************************************
;
CompilerIf #PB_Compiler_IsMainFile
; The following won't run when this file is used as 'Included'.
;
If OpenWindow(0, 100, 100, 400, 180, "FontRequester Demo", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
ButtonGadget(1, 50, 20, 300, 40, "Classical FontRequester")
ButtonGadget(2, 50, 70, 300, 40, "Zapman FontRequester")
ButtonGadget(3, 50, 120, 300, 40, "FontRequesterEx")
;
Repeat
Select WaitWindowEvent()
Case #PB_Event_Gadget
If EventGadget() = 1
If FontRequester("Segoe ui", 9, #PB_FontRequester_Effects, $FF0000, #PB_Font_Italic, WindowID(0))
; Show selected font
SetGadgetText(1, SelectedFontName() + " - " + Str(SelectedFontSize()) + " pts")
EndIf
EndIf
If EventGadget() = 2
If ZapmanFontRequester("Segoe ui", 9, #PB_FontRequester_Effects, $FF0000, #PB_Font_Italic, WindowID(0), 70, 120)
; Show selected font
SetGadgetText(2, ZapmanFontName() + " - " + Str(ZapmanFontSize()) + " pts")
EndIf
EndIf
If EventGadget() = 3
UserChoice = 0
ChoseFont$ = FontRequesterEx("Segoe ui, 9, Italic", #ZFR_FontRequester_Effects, WindowID(0), 70, 120, @UserChoice)
If UserChoice
; Show selected font
SetGadgetText(3, ChoseFont$)
EndIf
EndIf
Case #PB_Event_CloseWindow
Break
EndSelect
ForEver
EndIf
;
CompilerEndIf
I really understand that!
