Date: 02-16-2022
Return to Index
created by gbSnippets
'Often a programmer needs to size text (change the font) so that it fills
'an area as much as possible. Since there is no Windows API to return a font
'given an area to fill, programmers have to provide their own code.
'Primary Code:
'Credit: Paul Dixon
'Here's an approximation approach to getting the font size that will fill any area. This has
'the advantage of making no assumptions about maximum font size.
fSize& = IIF( w<h, 0.2*w, 0.2*h)
'However, the above equation gives limited results. This second approach, which assumes the
'font size will be no larger than 1000pts, gives a much better answer - and is very fast!
Function GetFontSize_Graphic2(w As Long, h As Long, txt$, scalefactor As Single, fontName$) As Long
Local x As Long, y As Long
Graphic Font fontName$, 1000, 1
Graphic Text Size txt$ To x,y
Function= 1000/IIF( x/w > y/h , x/(w*scalefactor) , y/(h*scalefactor) )
End Function
'This following function gives an exact answer by looping through font sizes until a font
'size is found that just fits the given text in the area. The drawback to this is speed -
'as a result of looping action.
Function GetFontSize_Graphic3(w As Long, h As Long, txt$, factor As Single, fName$) As Long
Local x As Long, y As Long, fS&
Do Until x > factor * w Or y > factor * h
Incr fS&
Graphic Font fName$, fS&, 1
Graphic Text Size txt$ To x,y
Loop
Function = fS&
End Function
'Finally, here's another exact solution, but this time using a binary search routine to
'minimize the number of loops required to find the answer.
Function GetFontSize_Graphic4(w As Long, h As Long, txt$, factor As Single, fName$) As Long
Local x As Long, y As Long, fSize As Long, Upper As Long, Lower As Long
Lower = 1 : Upper = 1000
Do Until (Upper <= (Lower + 1))
fSize = (Lower + Upper) / 2
Graphic Font fName$, fSize, 1
Graphic Text Size txt$ To x,y
If (x < factor*w) AND (y < factor*h) Then
Lower = fSize 'fits inside
Else
Upper = fSize 'goes outside
End If
Loop
Function = Lower
End Function
'Compilable Example: (Jose Includes)
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#Include "win32api.inc"
Global hDlg As Dword
Function PBMain () As Long
Local w As Long, h As Long
Desktop Get Client To w, h
Dialog New Pixels, 0, "Control Resize",100,100,200,200, %WS_OverlappedWindow To hDlg
Control Add Graphic, hDlg, 300,"", 0,0,w,h, %WS_Visible Or %SS_Sunken
Graphic Attach hDlg, 300, Redraw
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Select Case CB.Msg
Case %WM_Size
Dim w As Long, h As Long, x As Long, y As Long, txt$, fSize&, fName$
Dialog Get Client CB.Hndl To w,h
Control Set Size CB.Hndl, 300, w-20, h-20
txt$ = "Sample Text"
fName$ = "Comic MS Sans"
'get fontsize
fSize& = GetFontSize_Graphic4(w, h, txt$, 0.9, fName$)
'center and print
Graphic Clear
Graphic Font fName$, fSize&, 1
Graphic Text Size txt$ To x,y
Graphic Set Pos ((w-x)/2,(h-y)/2)
Graphic Print txt$
Graphic Redraw
End Select
End Function
Function GetFontSize_Graphic2(w As Long, h As Long, txt$, factor As Single, fontName$) As Long
Local x As Long, y As Long
Graphic Font fontName$, 1000, 1
Graphic Text Size txt$ To x,y
Function= 1000/IIF( x/w > y/h , x/(w*factor) , y/(h*factor) )
End Function
Function GetFontSize_Graphic3(w As Long, h As Long, txt$, factor As Single, fName$) As Long
Local x As Long, y As Long, fS&
Do Until x > factor * w Or y > factor * h
Incr fS&
Graphic Font fName$, fS&, 1
Graphic Text Size txt$ To x,y
Loop
Dialog Set Text hDlg, Str$(fS&)
Function = fS&
End Function
Function GetFontSize_Graphic4(w As Long, h As Long, txt$, factor As Single, fName$) As Long
Local x As Long, y As Long, fSize As Long, Upper As Long, Lower As Long
Lower = 1 : Upper = 1000
Do Until (Upper <= (Lower + 1))
fSize = (Lower + Upper) / 2
Graphic Font fName$, fSize, 1
Graphic Text Size txt$ To x,y
If (x < factor*w) AND (y < factor*h) Then
Lower = fSize 'fits inside
Else
Upper = fSize 'goes outside
End If
Loop
Function = Lower
End Function
'gbs_00360
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm