Hello all,
is there a way to only display fixed width fonts in the fontrequester?
Cheers!
Font requester for fixed width fonts only
- aaaaaaaargh
- User
- Posts: 55
- Joined: Thu Jul 27, 2006 1:24 pm
Re: Font requester for fixed width fonts only
Hi
Code: Select all
Procedure EnumFontProc(*lpelf.ENUMLOGFONT, *lpntm.NEWTEXTMETRIC, FontType, lParam)
font$ = PeekS(@*lpelf\elfLogFont\lfFaceName[0])
LoadFont(0,font$,10)
StartDrawing(WindowOutput(0))
DrawingFont(FontID(0))
tw1 = TextWidth("W")
tw2 = TextWidth("i")
If tw1 = tw2 And Left(font$,1) <> "@"
AddGadgetItem (0,-1,font$)
EndIf
StopDrawing()
FreeFont(0)
ProcedureReturn 1
EndProcedure
Procedure Monospace_fonts()
hDC = GetDC_(WindowID(0))
EnumFontFamilies_(hDC, 0, @EnumFontProc(), 0)
ReleaseDC_ (WindowID(0), hDC)
EndProcedure
OpenWindow(0,0,0,200,200,"Monospace Fonts",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
ListViewGadget(0,10,10,180,180)
Monospace_fonts()
Repeat
Select WaitWindowEvent()
Case #PB_Event_CloseWindow
Quit = 1
EndSelect
Until Quit = 1
Egypt my love
- aaaaaaaargh
- User
- Posts: 55
- Joined: Thu Jul 27, 2006 1:24 pm
Re: Font requester for fixed width fonts only
Hi Rashad,
that works great, thanks for that!
Just one more thing, (sorry) is there a way to find the valid font sizes so that a Fontrequester-like dialog could be made? (Especially for raster fonts)
Cheers
that works great, thanks for that!
Just one more thing, (sorry) is there a way to find the valid font sizes so that a Fontrequester-like dialog could be made? (Especially for raster fonts)
Cheers
-
- Enthusiast
- Posts: 334
- Joined: Mon Feb 04, 2013 5:28 pm
Re: Font requester for fixed width fonts only
Should be better to use
logfont\lfPitchAndFamily = #FIXED_PITCH | #FF_DONTCARE
and then enumerate.
https://msdn.microsoft.com/en-us/library/windows/desktop/dd145037(v=vs.85).aspx
logfont\lfPitchAndFamily = #FIXED_PITCH | #FF_DONTCARE
and then enumerate.
https://msdn.microsoft.com/en-us/library/windows/desktop/dd145037(v=vs.85).aspx
Re: Font requester for fixed width fonts only
Hi aaaaaaaargh
The rest is yours to delete the repeated sizes and sort the rest
Edit :Complete example
The rest is yours to delete the repeated sizes and sort the rest
Code: Select all
Global font$,oldfont$,hDC,item
Global NewList sList.i()
Procedure EnumFontSizes(*plf.LOGFONT,*ptm.TEXTMETRIC,FontType,lParam)
logsize = *ptm\tmHeight - *ptm\tmInternalLeading
pointsize = MulDiv_(logsize, 72, GetDeviceCaps_(hdc, #LOGPIXELSY))
Restore FontData
For n = 0 To 15
Read.l fsize
If fsize <> pointsize And pointsize < 24
AddElement(sList())
sList() = pointsize
ProcedureReturn 1
Else
ProcedureReturn 0
EndIf
Next
EndProcedure
Procedure GetFontSizes(font$)
lf.LOGFONT
lf\lfHeight = 0
lf\lfCharSet = #DEFAULT_CHARSET
lf\lfPitchAndFamily = #FIXED_PITCH|#FF_DONTCARE
PokeS(@lf\lfFaceName,font$)
hDC = GetDC_(WindowID(0))
EnumFontFamiliesEx_(hDC, lf, @EnumFontSizes(), 0 ,0)
ReleaseDC_ (WindowID(0), hDC)
EndProcedure
Procedure EnumFixedFonts(*lpelfe.ENUMLOGFONTEX, *lpntme.NEWTEXTMETRICEX,FontType,lParam)
font$ = PeekS(@*lpelfe\elfFullName)
If *lpelfe\elfLogFont\lfPitchAndFamily & #FIXED_PITCH And font$ <> oldfont$ And Left(font$,1) <> "@"
AddGadgetItem (0,-1,font$)
oldfont$ = font$
EndIf
ProcedureReturn 1
EndProcedure
Procedure Monospace_fonts()
lf.LOGFONT
lf\lfCharSet = #DEFAULT_CHARSET
lf\lfPitchAndFamily = #FIXED_PITCH|#FF_DONTCARE
hDC = GetDC_(WindowID(0))
EnumFontFamiliesEx_(hDC, lf, @EnumFixedFonts(), 0 ,0)
ReleaseDC_ (WindowID(0), hDC)
EndProcedure
LoadFont(0,"tahoma",14)
OpenWindow(0,0,0,700,300,"Monospace Fonts",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
ListIconGadget(0,10,10,680,280,"Font Name",220,#PB_ListIcon_GridLines|#PB_ListIcon_FullRowSelect)
SetGadgetFont(0,FontID(0))
AddGadgetColumn(0, 1, "Font Size",420)
Monospace_fonts()
For item = 0 To CountGadgetItems(0)-1
GetFontSizes(GetGadgetItemText(0,item,0))
SortList(sList(),#PB_Sort_Ascending)
ForEach sList()
If sList() = curelement
DeleteElement(sList())
EndIf
curelement = sList()
Next
ForEach sList()
Text$ = Text$ +Str(slist())+" "
Next
If Text$ = ""
Text$ = "8 9 10 11 12 14 16 18 20 22 24 26 28 36 48 72"
SetGadgetItemText(0, item, Text$ , 1)
Else
SetGadgetItemText(0, item, Text$ , 1)
EndIf
text$ = ""
ClearList(sList())
Next
Repeat
Select WaitWindowEvent()
Case #PB_Event_CloseWindow
Quit = 1
EndSelect
Until Quit = 1
DataSection
FontData:
Data.l 8, 9, 10, 11, 12, 14, 16, 18, 20, 22, 24, 26, 28, 36, 48, 72
EndDataSection
Egypt my love
Re: Font requester for fixed width fonts only
So simple
But it was a good practice maybe I will need it in the future
But it was a good practice maybe I will need it in the future
Code: Select all
FontName$ = "Arial" ; set initial font (could also be blank)
FontSize = 14 ; set initial size (could also be null)
Result = FontRequester(FontName$, FontSize, #CF_WYSIWYG|#CF_EFFECTS|#CF_FIXEDPITCHONLY )
If Result
Message$ = "You have selected following font:" + #LF$
Message$ + "Name: " + SelectedFontName() + #LF$
Message$ + "Size: " + Str(SelectedFontSize()) + #LF$
Message$ + "Color: " + Str(SelectedFontColor()) + #LF$
If SelectedFontStyle() & #PB_Font_Bold
Message$ + "Bold" + #LF$
EndIf
If SelectedFontStyle() & #PB_Font_StrikeOut
Message$ + "StrikeOut" + #LF$
EndIf
If SelectedFontStyle() & #PB_Font_Underline
Message$ + "Underline" + #LF$
EndIf
Else
Message$ = "The requester was canceled."
EndIf
MessageRequester("FontRequester", Message$, #PB_MessageRequester_Ok)
Egypt my love
- aaaaaaaargh
- User
- Posts: 55
- Joined: Thu Jul 27, 2006 1:24 pm
Re: Font requester for fixed width fonts only
Wow this just keeps getting better! Thank you ever so much!RASHAD wrote:So simple
But it was a good practice maybe I will need it in the future
Code: Select all
FontName$ = "Arial" ; set initial font (could also be blank) FontSize = 14 ; set initial size (could also be null) Result = FontRequester(FontName$, FontSize, #CF_WYSIWYG|#CF_EFFECTS|#CF_FIXEDPITCHONLY ) If Result Message$ = "You have selected following font:" + #LF$ Message$ + "Name: " + SelectedFontName() + #LF$ Message$ + "Size: " + Str(SelectedFontSize()) + #LF$ Message$ + "Color: " + Str(SelectedFontColor()) + #LF$ If SelectedFontStyle() & #PB_Font_Bold Message$ + "Bold" + #LF$ EndIf If SelectedFontStyle() & #PB_Font_StrikeOut Message$ + "StrikeOut" + #LF$ EndIf If SelectedFontStyle() & #PB_Font_Underline Message$ + "Underline" + #LF$ EndIf Else Message$ = "The requester was canceled." EndIf MessageRequester("FontRequester", Message$, #PB_MessageRequester_Ok)
Many thanks & cheers