Fit String To Area (Graphic Control)

Category: Strings

Date: 03-28-2012

Return to Index


 
'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:
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
#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


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm