By using this site, you agree to our updated Privacy Policy and our Terms of Use. Manage your Cookies Settings.
426,107 Members | 1,323 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 426,107 IT Pros & Developers. It's quick & easy.

Change font size to fit label dimensions.

PhilOfWalton
Expert 100+
P: 1,430
I have a label size W = Width & H = Height. It initially has a caption of say 30 letters in 4 words, each word separated by either a space or a line feed. Initially the label is about the right size for the caption in the selected font.

Using VBA, I now want to change the caption to say 45 letters in 5 words.
Using the late Stephen Lebanís fTextWidthOrHeight routine, I can get the width and height of new wording in the same font.

What I want to do is reduce the font size if necessary so that it still fits in the label area.
This partially works

Expand|Select|Wrap|Line Numbers
  1. Function ShrinkFont(Ctl As Control)
  2.  
  3.     'See if the text will fit the in the label or command button
  4.     ' Note that a line feed in a caplion is Chr(13) & Chr$(10) = vbCrLf
  5.     Dim TextWidth As Long
  6.     Dim TextHeight As Long
  7.     TextWidth = fTextWidth(Ctl, Ctl.Caption)        ' Get the width of the caption
  8.     TextHeight = fTextHeight(Ctl, Ctl.Caption)        ' Get the Height of the caption
  9.  
  10. ' Control too narrow, so must shrink font (if neccessary) Need to see if there is a spare line
  11.     Do Until TextWidth < Ctl.Width
  12.             TextWidth = fTextWidth(Ctl, Ctl.Caption)
  13.             Ctl.FontSize = Ctl.FontSize - 1
  14.             If Ctl.FontSize < TempVars!PP_ResizeFont Then                         ' Too small
  15.                 Exit Do
  16.             End If
  17.         Loop
  18.  
  19. End Function
  20.  
TempVars!PP_ResizeFont is the minimum font size that I want to go, currently set at 8.

Where it falls down is that as the font shrinks, the height of the font also shrinks, so there is the potential to spread the caption over more lines, and thus not reduce the font size more than is necessary.

So somehow, I think I need to replace vbCrLf with spaces, work out what can fit on what line and shrink the font as little as possible with the proviso that any line breaks can only come on a space between words.

Can anybody start me off please

Phil
Sep 28 '17 #1
Share this Question
Share on Google+
11 Replies


NeoPa
Expert Mod 15k+
P: 31,419
Hi Phil.

Presumably the starting font size is such that it will fit at least two lines of font size 8? Will it be larger? If you know the font size where it changes from handling only one line to allowing two then that could be set as a constant and checked for.

I doubt line feeds will be required. When multiple words are used in a Caption which is too narrow to show all on one line then it wraps automatically.
Sep 30 '17 #2

PhilOfWalton
Expert 100+
P: 1,430
Actually, no

Initially say the font size is 12 (At my age I like a big font)
The label is a at least big enough in a combination of height and width to accommodate the initial 30 letter caption.

I can't change the size of the label because it may overlap other controls on the form or report, so my thought is to progressively reduce the font size until it fits.

Mow as the font size reduces, not only does the width reduce, but also the height, so we may get the situation where the font size has been reduced by 1, the line is still too long, but now, with the reduced height of the font, there is enough room to use 2 lines rather than the initial single line.

I knew this was going to be tough one.

I have written some code that seems to work, but it is spaghetti code and I have little confidence in it.

My addition is the Sub ShrinkFont(Ctl As Control)
Expand|Select|Wrap|Line Numbers
  1. Option Compare Database
  2. Option Explicit
  3.  
  4. Private Type RECT
  5.         Left As Long
  6.         Top As Long
  7.         Right As Long
  8.         Bottom As Long
  9. End Type
  10.  
  11. Private Const LF_FACESIZE = 32
  12.  
  13. Private Type LOGFONT
  14.         lfHeight As Long
  15.         lfWidth As Long
  16.         lfEscapement As Long
  17.         lfOrientation As Long
  18.         lfWeight As Long
  19.         lfItalic As Byte
  20.         lfUnderline As Byte
  21.         lfStrikeOut As Byte
  22.         lfCharSet As Byte
  23.         lfOutPrecision As Byte
  24.         lfClipPrecision As Byte
  25.         lfQuality As Byte
  26.         lfPitchAndFamily As Byte
  27.         lfFaceName As String * LF_FACESIZE
  28. End Type
  29.  
  30. Private Type TEXTMETRIC
  31.         tmHeight As Long
  32.         tmAscent As Long
  33.         tmDescent As Long
  34.         tmInternalLeading As Long
  35.         tmExternalLeading As Long
  36.         tmAveCharWidth As Long
  37.         tmMaxCharWidth As Long
  38.         tmWeight As Long
  39.         tmOverhang As Long
  40.         tmDigitizedAspectX As Long
  41.         tmDigitizedAspectY As Long
  42.         tmFirstChar As Byte
  43.         tmLastChar As Byte
  44.         tmDefaultChar As Byte
  45.         tmBreakChar As Byte
  46.         tmItalic As Byte
  47.         tmUnderlined As Byte
  48.         tmStruckOut As Byte
  49.         tmPitchAndFamily As Byte
  50.         tmCharSet As Byte
  51. End Type
  52.  
  53. Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" _
  54. (ByVal hDC As Long, lpMetrics As TEXTMETRIC) As Long
  55.  
  56. Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
  57.         "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
  58.  
  59. Private Declare Function apiSelectObject Lib "gdi32" Alias "SelectObject" _
  60. (ByVal hDC As Long, _
  61. ByVal hObject As Long) As Long
  62.  
  63. Private Declare Function apiDeleteObject Lib "gdi32" _
  64.   Alias "DeleteObject" (ByVal hObject As Long) As Long
  65.  
  66. Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
  67. (ByVal hDC As Long, ByVal nIndex As Long) As Long
  68.  
  69. Private Declare Function apiMulDiv Lib "kernel32" Alias "MulDiv" _
  70. (ByVal nNumber As Long, _
  71. ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
  72.  
  73. Private Declare Function apiGetDC Lib "user32" _
  74.   Alias "GetDC" (ByVal hwnd As Long) As Long
  75.  
  76. Private Declare Function apiReleaseDC Lib "user32" _
  77.  Alias "ReleaseDC" (ByVal hwnd As Long, _
  78.  ByVal hDC As Long) As Long
  79.  
  80. Private Declare Function apiDrawText Lib "user32" Alias "DrawTextA" _
  81. (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, _
  82. lpRect As RECT, ByVal wFormat As Long) As Long
  83.  
  84. Private Declare Function CreateDCbyNum Lib "gdi32" Alias "CreateDCA" _
  85. (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
  86. ByVal lpOutput As Long, ByVal lpInitData As Long) As Long  'DEVMODE) As Long
  87.  
  88. Private Declare Function apiDeleteDC Lib "gdi32" _
  89.   Alias "DeleteDC" (ByVal hDC As Long) As Long
  90.  
  91. Declare Function GetProfileString Lib "kernel32" _
  92.    Alias "GetProfileStringA" _
  93.   (ByVal lpAppName As String, _
  94.    ByVal lpKeyName As String, _
  95.    ByVal lpDefault As String, _
  96.    ByVal lpReturnedString As String, _
  97.    ByVal nSize As Long) As Long
  98.  
  99.  
  100.  
  101.  
  102. ' CONSTANTS
  103. Private Const TWIPSPERINCH = 1440
  104. ' Used to ask System for the Logical pixels/inch in X & Y axis
  105. Private Const LOGPIXELSY = 90
  106. Private Const LOGPIXELSX = 88
  107.  
  108. ' DrawText() Format Flags
  109. Private Const DT_TOP = &H0
  110. Private Const DT_LEFT = &H0
  111. Private Const DT_CALCRECT = &H400
  112. Private Const DT_WORDBREAK = &H10
  113. Private Const DT_EXTERNALLEADING = &H200
  114. Private Const DT_EDITCONTROL = &H2000&
  115.  
  116.  
  117. ' Font stuff
  118. Private Const OUT_DEFAULT_PRECIS = 0
  119. Private Const OUT_STRING_PRECIS = 1
  120. Private Const OUT_CHARACTER_PRECIS = 2
  121. Private Const OUT_STROKE_PRECIS = 3
  122. Private Const OUT_TT_PRECIS = 4
  123. Private Const OUT_DEVICE_PRECIS = 5
  124. Private Const OUT_RASTER_PRECIS = 6
  125. Private Const OUT_TT_ONLY_PRECIS = 7
  126. Private Const OUT_OUTLINE_PRECIS = 8
  127.  
  128. Private Const CLIP_DEFAULT_PRECIS = 0
  129. Private Const CLIP_CHARACTER_PRECIS = 1
  130. Private Const CLIP_STROKE_PRECIS = 2
  131. Private Const CLIP_MASK = &HF
  132. Private Const CLIP_LH_ANGLES = 16
  133. Private Const CLIP_TT_ALWAYS = 32
  134. Private Const CLIP_EMBEDDED = 128
  135.  
  136. Private Const DEFAULT_QUALITY = 0
  137. Private Const DRAFT_QUALITY = 1
  138. Private Const PROOF_QUALITY = 2
  139.  
  140. Private Const DEFAULT_PITCH = 0
  141. Private Const FIXED_PITCH = 1
  142. Private Const VARIABLE_PITCH = 2
  143.  
  144. Private Const ANSI_CHARSET = 0
  145. Private Const DEFAULT_CHARSET = 1
  146. Private Const SYMBOL_CHARSET = 2
  147. Private Const SHIFTJIS_CHARSET = 128
  148. Private Const HANGEUL_CHARSET = 129
  149. Private Const CHINESEBIG5_CHARSET = 136
  150. Private Const OEM_CHARSET = 255
  151. '
  152.  
  153. Public Function fTextHeight(Ctl As Control, _
  154. Optional ByVal sText As String = "", _
  155. Optional HeightTwips As Long = 0, Optional WidthTwips As Long = 0, _
  156. Optional TotalLines As Long = 0) As Long
  157.  
  158. On Error Resume Next
  159.  
  160. ' Call our function to calculate TextHeight
  161. ' If blWH=TRUE then we are TextHeight
  162. fTextHeight = fTextWidthOrHeight(Ctl, True, _
  163. sText, HeightTwips, WidthTwips, TotalLines)
  164.  
  165. End Function
  166.  
  167.  
  168. Public Function fTextWidth(Ctl As Control, _
  169. Optional ByVal sText As String = "", _
  170. Optional HeightTwips As Long = 0, Optional WidthTwips As Long = 0, _
  171. Optional TotalLines As Long = 0) As Long
  172.  
  173. On Error Resume Next
  174.  
  175. ' If blWH=FALSE then we are TextWidth
  176. ' Call our function to calculate TextWidth
  177. fTextWidth = fTextWidthOrHeight(Ctl, False, _
  178. sText, HeightTwips, WidthTwips)
  179.  
  180. End Function
  181.  
  182.  
  183.  Public Function fTextWidthOrHeight(Ctl As Control, ByVal blWH As Boolean, _
  184.  Optional ByVal sText As String = "", _
  185.  Optional HeightTwips As Long = 0, Optional WidthTwips As Long = 0, _
  186.  Optional TotalLines As Long = 0) As Long
  187.  
  188.  'Name                   FUNCTION() fTextWidthOrHeight
  189.  '
  190.  
  191.  'Purpose:               Returns the Height or Width needed to
  192.  '                       display the contents of the Control passed
  193.  '                       to this function. This function
  194.  '                       uses the Control's font attributes to build
  195.  '                       a Font for the required calculations.
  196.  '
  197.  '                       This function replaces the Report object's TextHeight
  198.  '                       and TextWidth methods which only work for a single line of text.
  199.  '                       This function works with multiple lines of text and
  200.  '                       also with both Forms and Reports.
  201.  '
  202.  'Version:               4.1
  203.  '
  204.  'Calls:                 Text API stuff. DrawText performs the actual
  205.  '                       calculation to determine Control Height.
  206.  '
  207.  'Returns:               Height or width of Control in TWIPS required
  208.  '                       to display current contents.
  209.  '
  210.  'Created by:            Stephen Lebans
  211.  '
  212.  'Credits:               If you want some...take some.
  213.  '
  214.  'Date:                  May 22, 2001
  215.  '
  216.  'Time:                  10:10:10pm
  217.  '
  218.  'Feedback:              Stephen@lebans.com
  219.  '
  220.  'My Web Page:           www.lebans.com
  221.  '
  222.  'Copyright:             Lebans Holdings Ltd.
  223.  '                       Please feel free to use this code
  224.  '                       without restriction in any application you develop.
  225.  '                       This code may not be resold by itself or as
  226.  '                       part of a collection.
  227.  '
  228.  'What's Missing:        Let me know!
  229.  '
  230.  '
  231.  '
  232.  'Bugs:
  233.  'None at this point.
  234.  '
  235.  'Enjoy
  236.  'Stephen Lebans
  237.  
  238.  '***************Code Start***************
  239.  
  240.  ' Structure for DrawText calc
  241.  Dim sRect As RECT
  242.  
  243.  ' Reports Device Context
  244.  Dim hDC As Long
  245.  
  246.  ' Holds the current screen resolution
  247.  Dim lngDPI As Long
  248.  
  249.  Dim newfont As Long
  250.  ' Handle to our Font Object we created.
  251.  ' We must destroy it before exiting main function
  252.  
  253.  Dim oldfont As Long
  254.  ' Device COntext's Font we must Select back into the DC
  255.  ' before we exit this function.
  256.  
  257.  ' Temporary holder for returns from API calls
  258.  Dim lngRet As Long
  259.  
  260.  ' Logfont struct
  261.  Dim myfont As LOGFONT
  262.  
  263.  ' TextMetric struct
  264.  Dim tm As TEXTMETRIC
  265.  
  266.  ' LineSpacing Amount
  267.  Dim lngLineSpacing As Long
  268.  
  269.  ' Ttemp var
  270.  Dim numLines As Long
  271.  
  272.  ' Temp string var for current printer name
  273.  Dim strName As String
  274.  
  275.  On Error GoTo Err_Handler
  276.  
  277. ' If we are being called from a Form then SKIP
  278. ' the logic to Create a Printer DC and simply use
  279. ' the Screen's DC
  280.  
  281. If TypeOf Ctl.Parent Is Access.Report Then
  282.     ' ***************************************************
  283.     ' Warning! Do not use Printer's Device Context for Forms.
  284.     ' This alternative is meant for Report's only!!!!!
  285.     ' For a Report the best accuracy is obtained if you get a handle to
  286.     ' the printer's Device Context instead of the Screen's.
  287.     ' You can uncomment his code and comment out the
  288.     ' apiGetDc line of code.
  289.     ' We need to use the Printer's Device Context
  290.     ' in order to more closely match Font height calcs
  291.     ' with actual ouptut. This example simply uses the
  292.     ' default printer for the system. You could also
  293.     ' add logic to use the Devnames property if this
  294.     ' report prints to a specific printer.
  295.     strName = GetDefaultPrintersName
  296.     hDC = CreateDCbyNum("WINSPOOL", strName, 0&, 0&)
  297.     If hDC = 0 Then
  298.         ' Error cannot get handle to printer Device Context
  299.         Err.Raise vbObjectError + 255, "fTextWidthOrHeight", "Cannot Create Printer DC"
  300.     End If
  301.     ' ***************************************************
  302. Else
  303.     ' Get handle to screen Device Context
  304.     hDC = apiGetDC(0&)
  305. End If
  306.  
  307.  ' Were we passed a valid string
  308.  If Len(sText & vbNullString) = 0 Then
  309.      ' Did we get a valid control passed to us?
  310.      'select case typeof ctl is
  311.      Select Case Ctl.ControlType
  312.  
  313.          Case acTextBox
  314.          sText = Nz(Ctl.Value, vbNullString)
  315.  
  316.          '~~~~Case acLabel, acCommandButton, acPage
  317.  
  318.          Case acLabel, acPage, acToggleButton, acCommandButton
  319.          sText = Nz(Ctl.Caption, vbNullString)
  320.  
  321.          Case Else
  322.          ' Fail - not a control we can work with
  323.          fTextWidthOrHeight = 0
  324.          Exit Function
  325.      End Select
  326.  End If
  327.  
  328.  
  329.  ' Get current device resolution
  330.  ' blWH=TRUE then we are TextHeight
  331.  If blWH Then
  332.      lngDPI = apiGetDeviceCaps(hDC, LOGPIXELSY)
  333.  Else
  334.      lngDPI = apiGetDeviceCaps(hDC, LOGPIXELSX)
  335.  End If
  336.  
  337.  ' We use a negative value to signify
  338.  ' to the CreateFont function that we want a Glyph
  339.  ' outline of this size not a bounding box.
  340.  ' Copy font stuff from Text Control's property sheet
  341.  With Ctl
  342.         myfont.lfClipPrecision = CLIP_LH_ANGLES
  343.         myfont.lfOutPrecision = OUT_TT_ONLY_PRECIS
  344.         myfont.lfEscapement = 0
  345.         If Ctl.ControlType = acPage Then
  346.             myfont.lfFaceName = Ctl.Parent.FontName & Chr$(0)
  347.             myfont.lfWeight = Ctl.Parent.FontWeight
  348.             myfont.lfItalic = Ctl.Parent.FontItalic
  349.             myfont.lfUnderline = Ctl.Parent.FontUnderline
  350.             'Must be a negative figure for height or system will return
  351.             'closest match on character cell not glyph
  352.             myfont.lfHeight = (Ctl.Parent.FontSize / 72) * -lngDPI
  353.             ' Create our temp font
  354.             newfont = apiCreateFontIndirect(myfont)
  355.          Else
  356.             myfont.lfFaceName = .FontName & Chr$(0)
  357.             myfont.lfWeight = .FontWeight
  358.             myfont.lfItalic = .FontItalic
  359.             myfont.lfUnderline = .FontUnderline
  360.             'Must be a negative figure for height or system will return
  361.             'closest match on character cell not glyph
  362.             myfont.lfHeight = (.FontSize / 72) * -lngDPI
  363.             ' Create our temp font
  364.             newfont = apiCreateFontIndirect(myfont)
  365.         End If
  366.     End With
  367.  
  368.      If newfont = 0 Then
  369.          Err.Raise vbObjectError + 256, "fTextWidthOrHeight", "Cannot Create Font"
  370.      End If
  371.  
  372.  ' Select the new font into our DC.
  373.  oldfont = apiSelectObject(hDC, newfont)
  374.  
  375.  ' Use DrawText to Calculate height of Rectangle required to hold
  376.  ' the current contents of the Control passed to this function.
  377.  
  378.     With sRect
  379.         .Left = 0
  380.         .Top = 0
  381.         .Bottom = 0
  382.         ' blWH=TRUE then we are TextHeight
  383.         If blWH Then
  384.             .Right = (Ctl.Width / (TWIPSPERINCH / lngDPI)) - 10
  385.         Else
  386.         ' Single line TextWidth
  387.             .Right = 32000
  388.         End If
  389.  
  390.    ' Calculate our bounding box based on the controls current width
  391.    lngRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or _
  392.    DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL)
  393.  
  394.    ' Get TextMetrics. This is required to determine
  395.    ' Text height and the amount of extra spacing between lines.
  396.    lngRet = GetTextMetrics(hDC, tm)
  397.  
  398.    ' Cleanup
  399.    lngRet = apiSelectObject(hDC, oldfont)
  400.    ' Delete the Font we created
  401.    apiDeleteObject (newfont)
  402.  
  403.   If TypeOf Ctl.Parent Is Access.Report Then
  404.     ' ***************************************************
  405.     ' If you are using the Printers' DC then uncomment below
  406.     ' and comment out the apiReleaseDc line of code below
  407.     ' Delete our handle to the Printer DC
  408.     lngRet = apiDeleteDC(hDC)
  409.     ' ***************************************************
  410.   Else
  411.     ' Release the handle to the Screen's DC
  412.     lngRet = apiReleaseDC(0&, hDC)
  413.   End If
  414.  
  415.  ' Calculate how many lines we are displaying
  416.  ' return to calling function. The GDI incorrectly
  417.  ' calculates the bounding rectangle because
  418.  ' of rounding errors converting to Integers.
  419.  TotalLines = .Bottom / (tm.tmHeight + tm.tmExternalLeading)
  420.  numLines = TotalLines
  421.  
  422.  ' Convert RECT values to TWIPS
  423.  .Bottom = (.Bottom) * (TWIPSPERINCH / lngDPI)
  424.  
  425.  ' ***************************************************
  426.  ' For A2K only!
  427.  ' Now we need to add in the amount of the
  428.  ' line spacing property.
  429.  'lngLineSpacing = ctl.LineSpacing * (numLines - 1)
  430.  'If numLines = 1 Then lngLineSpacing = lngLineSpacing + (ctl.LineSpacing / 2)
  431.  ' Increase our control's height accordingly
  432.  '.Bottom = .Bottom + lngLineSpacing
  433.  
  434.  
  435.    ' Return values in optional vars
  436.    ' Convert RECT Pixel values to TWIPS
  437.    HeightTwips = .Bottom '* (TWIPSPERINCH / lngDPI)
  438.    WidthTwips = .Right * (TWIPSPERINCH / lngDPI) '(apiGetDeviceCaps(hDC, LOGPIXELSX)))
  439.  
  440.    ' blWH=TRUE then we are TextHeight
  441.    If blWH Then
  442.      fTextWidthOrHeight = HeightTwips
  443.    Else
  444.     fTextWidthOrHeight = WidthTwips
  445.    End If
  446. End With
  447.  
  448. ' Exit normally
  449. Exit_OK:
  450. Exit Function
  451.  
  452. Err_Handler:
  453. Err.Raise Err.Source, Err.Number, Err.Description
  454. Resume Exit_OK
  455. End Function
  456.  
  457. Function GetDefaultPrintersName() As String
  458. ' This function is from Peter Walker.
  459. ' Check out his web site at:
  460. ' http://www.users.bigpond.com/papwalker/
  461. Dim success As Long
  462. Dim nSize As Long
  463. Dim lpKeyName As String
  464. Dim ret As String
  465. Dim posDriver
  466. 'call the API passing null as the parameter
  467. 'for the lpKeyName parameter. This causes
  468. 'the API to return a list of all keys under
  469. 'that section. Pad the passed string large
  470. 'enough to hold the data. Adjust to suit.
  471. ret = Space$(8102)
  472. nSize = Len(ret)
  473. success = GetProfileString("windows", "device", "", ret, nSize)
  474. posDriver = InStr(ret, ",")
  475. GetDefaultPrintersName = Left$(ret, posDriver - 1)
  476. End Function
  477.  
  478. Sub ShrinkFont(Ctl As Control)
  479.     'See if the text will fit the in the label or command button
  480.     ' Note that a line feed in a caplion is Chr(13) & Chr$(10) = vbCrLf
  481.     Dim ActualText As String
  482.     Dim ActualTextWidth As Long
  483.     Dim ActualTextHeight As Long
  484.     Dim LineText As String              ' Text after reoving VbCrLf
  485.     Dim LineTextWidth As Long           ' Width of single line after reoving VbCrLf
  486.     Dim CtlArea As Long
  487.     Dim TextArea As Long
  488.     Dim Words() As String
  489.     Dim WordWidths() As Long
  490.     Dim MaxHeight As Long
  491.     Dim TmpHeight As Long
  492.     Dim i As Integer, LastWord As Integer, FirstWord As Integer, m As Integer
  493.     Dim LinesAvailable As Integer
  494.     Dim ControlVerticalSpace As Long
  495.     Dim ControlHorizontalSpace As Long
  496.     Dim SpaceWidth As Long
  497.     Dim TotalLength As Long
  498.     Dim NewCaption As String
  499.     Dim SpaceLeft As Long
  500.  
  501.     ControlVerticalSpace = Ctl.Height - (Ctl.TopPadding + Ctl.BottomPadding)
  502.     ControlHorizontalSpace = Ctl.Width - (Ctl.LeftPadding + Ctl.RightPadding)
  503.  
  504.     ActualText = Ctl.Caption
  505.     LineText = Replace(Ctl.Caption, Chr$(34) & Chr$(10), " ")       ' Rmove line feeds
  506.     Words = Split(LineText, " ")                                    ' Get each individual word
  507.     ReDim WordWidths(UBound(Words))
  508.  
  509. GetLineLengths:
  510.     NewCaption = ""
  511.     MaxHeight = 0
  512.     For i = 0 To UBound(Words)
  513.         WordWidths(i) = fTextWidth(Ctl, Words(i))
  514.         TmpHeight = fTextHeight(Ctl, Words(i))                      ' Maximum height of any word
  515.         If TmpHeight > MaxHeight Then
  516.             MaxHeight = TmpHeight
  517.         End If
  518.     Next i
  519.  
  520.     LinesAvailable = ControlVerticalSpace / MaxHeight
  521.     SpaceLeft = LinesAvailable * ControlHorizontalSpace             ' Space left to get words in
  522.  
  523.     ActualTextWidth = fTextWidth(Ctl, ActualText)                   ' Get the width of the caption
  524.     ActualTextHeight = fTextHeight(Ctl, ActualText)                 ' Get the Height of the caption
  525.     LineTextWidth = fTextWidth(Ctl, LineText)                       ' Get the width of the caption without line feeds
  526.     SpaceWidth = fTextWidth(Ctl, " ")                               ' Get the width of a space
  527.  
  528.     'Stop
  529.  
  530.     If ActualTextWidth < SpaceLeft Then                             ' Enough space for caption
  531.         Exit Sub
  532.     Else                                                            ' Not enough space
  533.         If Ctl.FontSize > TempVars!PP_ResizeFont Then               ' Are we at the mininum size font
  534.         Ctl.FontSize = Ctl.FontSize - 1                             ' Reduce it by 1
  535.         GoTo GetLineLengths                                         ' And see if it fits
  536.         End If
  537.     End If
  538.  
  539.     LastWord = 0
  540.     TotalLength = 0
  541.     FirstWord = LastWord                                            ' Where we started this scan
  542. GetNextLine:
  543.     ' Add the words until we get too long
  544.     i = FirstWord
  545.  
  546.     Do While i <= UBound(Words) And TotalLength < ControlHorizontalSpace
  547.         TotalLength = TotalLength + WordWidths(i) + SpaceWidth
  548.         i = i + 1
  549.     Loop
  550.  
  551.     TotalLength = TotalLength - SpaceWidth                          ' Remove length of final space
  552.     LastWord = i - 1                                                ' Last word that wil fit
  553.  
  554.     If LastWord > 0 Then
  555.         If LastWord = UBound(Words) Then                            ' Last word
  556.             LastWord = LastWord + 1
  557.         End If
  558.  
  559.         For m = FirstWord To LastWord - 1
  560.             NewCaption = NewCaption & Words(m) & vbCrLf             ' Words that will fit + line feed
  561.             TotalLength = TotalLength - WordWidths(m)               ' Reduce the length required by word length
  562.         Next m
  563.         TotalLength = TotalLength - SpaceWidth                      ' Replaces a space with a line feed
  564.         SpaceLeft = SpaceLeft - ControlHorizontalSpace              ' We have used a line up
  565.         FirstWord = LastWord
  566.         If TotalLength < 10 And TotalLength > -10 Then              ' pretty good fit
  567.             Ctl.Caption = NewCaption
  568.             Exit Sub
  569.         End If
  570.         If m >= UBound(Words()) And SpaceLeft >= 0 Then             ' All words done and space to spare
  571.             Ctl.Caption = NewCaption
  572.             Exit Sub
  573.         End If
  574.         GoTo GetNextLine
  575.     Else
  576.         Exit Sub                                                    ' No change
  577.     End If
  578.  
  579. End Sub
  580.  
  581.  
Sorry, this is a very long module

Phil
Sep 30 '17 #3

ADezii
Expert 5K+
P: 8,623
Phil, there is a very useful Property of an Access Report that can be used in this scenario called TextWidth. The Logic is as follows:
  1. Compute the Average Width of a Character using a Base String given a specific Font Name and Font Size in the Coordinate System used for the Report (Inches in this case).
  2. Establish the Length of your Label Control in Inches (in this case 7.9167).
  3. Open the Report in Hidden Mode and place the required Code in the Detail's Print() Event.
  4. Loop thru a desired Range of Font Sizes (in this case 24 thru 8).
  5. At the first instance where the (Average Character Length * Len(Test String)) was < 7.9167 (Label Length), this is the largest Font Size that can be used for a Label whose Width is 7.9167. My result was the largest Font Size with the Tahoma Font that can be used for a Label 7.9167 inches wide was 18 for the Test String.
  6. This does not address the Height adjustment, I'll leave that up to you.
  7. If you are interested in this approach, I'll send you the Demo.
  8. The results are not perfect, since a Font Size of 20 can actually be used in this scenario, close but no cigar! (LOL).
Sep 30 '17 #4

NeoPa
Expert Mod 15k+
P: 31,419
Phil:
Now as the font size reduces, not only does the width reduce, but also the height, so we may get the situation where the font size has been reduced by 1, the line is still too long, but now, with the reduced height of the font, there is enough room to use 2 lines rather than the initial single line.
If it starts at twelve and only goes down to 8 then surely you can check if 8 allows 2 lines without worrying about detecting it in code. If 8 does then see which is the first (You only have a choice of 8, 9, 10 & 11.) and use that value in your code.
Sep 30 '17 #5

PhilOfWalton
Expert 100+
P: 1,430
@ADezii

I certainly would like to see the Demo, but only if you have already got something. I suspect it isn't going to work for sevaral reasons

1) This needs to work for both Forms & Reports

2) As I understand it the Textwidth property works on the Report's FontName & FontSize, not the Control's FontName & FontSize. Certainly this was born out by the fact of changing the font of the control made not the slightest difference to the TextWidth values.

3) Mummy & India are both 5 letter words, but in pretty well any font other than Courier, Mummy is about 50% longer than india

@Neopa
I'm missing the point somewhere. Obviously I want to keep the largest font that will fit the caption into the label. Conceivable,reducing the font by 1 point may give enough horizontal space without worrying whether there is a second line available.

The ideal would be distribute the Caption in whatever horizontal and vertical space is available. If there is insufficient room and there are line feeds or spaces before the words, they should be removed before reducing the font size.

Thanks both for your help


Phil
Sep 30 '17 #6

ADezii
Expert 5K+
P: 8,623
This needs to work for both Forms & Reports
As the Demo will illustrate, the Code will place the largest size Font for a specific Test String into a Label on a Form. Since the TextWidth/TextHeight Properties exist on Reports only, it is the focal point for the Code. As far as I know, a given Font and Size are the same whether used in a Control on a Form or a Report. I changed the Coordinate System to TWIPS which gave more accurate results than Inches. I also added a Vertical Scaling Factor which factors in the ratio of the revised TextHeight (given the new Font Size) to the original TextHeight. In any event, if I am off on a tangent, I do apologize. Download the Demo and see if it can be of any use to you.
Attached Files
File Type: zip MAX Font Size.zip (82.2 KB, 44 views)
Oct 1 '17 #7

PhilOfWalton
Expert 100+
P: 1,430
I thought to clarify the problem I would show 3 images.

The original database was written in German so the first 2 pictures show a portion of a form in design view, then in form view.





I have a routine to translate the database into Russian (No idea whether it is correct or not, it's far from 100% accurate and won't translate words it can't recognise, and it assumes the whole form is in German ... but hey ho. Note that Homepage is not a German word, but surprisingly has been translated.

So this is the Russian version



As you see, by setting the minimum font size to 7, the font shrinks to fit the caption into the label.

Hope that clarifies matters a little

Phil
Oct 1 '17 #8

NeoPa
Expert Mod 15k+
P: 31,419
Phil:
Initially say the font size is 12 (At my age I like a big font)
Phil:
TempVars!PP_ResizeFont is the minimum font size that I want to go, currently set at 8.
Phil:
As you see, by setting the minimum font size to 7, the font shrinks to fit the caption into the label.
I was working to font size limits of 8 - 12. Now I admit to feeling a little lost.

8 - 12 is a spread of just 5 as you decrement by 1 each time. In such a scenario as I thought you were describing it makes sense to determine at which point 2 lines are used. If that's not true then we'd need to know what is true before considering what approaches are possible.
Oct 1 '17 #9

PhilOfWalton
Expert 100+
P: 1,430
Sorry, ADezii, I missed your post.
Have had look and it appears that the line

Expand|Select|Wrap|Line Numbers
  1. If (dblAvgSize * Len(strTestString)) < Forms![frmListWidth].Width Then
  2.  
Should be
Expand|Select|Wrap|Line Numbers
  1. If (dblAvgSize * Len(strTestString)) < Forms![frmListWidth]!lblItem.Width Then
  2.  
However I made the "She Sells...." half as wide and over 3 times the height, but the print only comes out in a single line size 9 whereas on the resized label, I can get size 20 font in 2 lines.

For the sake of completeness, I attach an image as preciously, but this time limited the font size to 8 rather than 7



As you see the labels are a mess.

As Neopa says if a youngster like you likes a 12 point font, what about an old f.rt like me.

The forms (Don't forget they are not designed by me as they are other peoples Dbs) can have any size font they like from 72 point downwards.

Initially I tried the TempVars!PP_ResizeFont at 8, but I think 7 may be better as most people don't use point sizes below 8 and using 7 gives some room to shrink the caption.

The parameters in a way are very simple. Given a label of fixed size and font characteristics other than font size (including name, bold, italic etc), and given the caption that has to fit in the label, working down from the original font size, what is the maximum font size we can get without dropping below say 7 points to get the caption to fit the label?

This revised code seems to give reasonable results, but it is messy and messy code is usually wrong.

Expand|Select|Wrap|Line Numbers
  1. Sub ShrinkFont(Ctl As Control)
  2.     'See if the text will fit the in the label or command button
  3.     ' Note that a line feed in a caplion is Chr(13) & Chr$(10) = vbCrLf
  4.     Dim ActualText As String
  5.     Dim ActualTextWidth As Long
  6.     Dim ActualTextHeight As Long
  7.     Dim LineText As String              ' Text after reoving VbCrLf
  8.     Dim LineTextWidth As Long           ' Width of single line after reoving VbCrLf
  9.     Dim CtlArea As Long
  10.     Dim TextArea As Long
  11.     Dim Words() As String
  12.     Dim WordWidths() As Long
  13.     Dim MaxHeight As Long
  14.     Dim TmpHeight As Long
  15.     Dim i As Integer, LastWord As Integer, FirstWord As Integer, m As Integer
  16.     Dim LinesAvailable As Integer
  17.     Dim ControlVerticalSpace As Long
  18.     Dim ControlHorizontalSpace As Long
  19.     Dim SpaceWidth As Long
  20.     Dim TotalLength As Long
  21.     Dim NewCaption As String
  22.     Dim SpaceLeft As Long
  23.  
  24.     If Ctl.ControlType = acPage Then                                ' Pages don't have padding
  25.         ControlVerticalSpace = Ctl.Height
  26.         ControlHorizontalSpace = Ctl.Width
  27.     Else
  28.         ControlVerticalSpace = Ctl.Height - (Ctl.TopPadding + Ctl.BottomPadding)
  29.         ControlHorizontalSpace = Ctl.Width - (Ctl.LeftPadding + Ctl.RightPadding)
  30.     End If
  31.  
  32.     ActualText = Ctl.Caption
  33.     LineText = Replace(Ctl.Caption, Chr$(34) & Chr$(10), " ")       ' Rmove line feeds
  34.     Words = Split(LineText, " ")                                    ' Get each individual word
  35.     ReDim WordWidths(UBound(Words))
  36.  
  37. GetLineLengths:
  38.     NewCaption = ""
  39.     MaxHeight = 0
  40.     For i = 0 To UBound(Words)
  41.         WordWidths(i) = fTextWidth(Ctl, Words(i))
  42.         TmpHeight = fTextHeight(Ctl, Words(i))                      ' Maximum height of any word
  43.         If TmpHeight > MaxHeight Then
  44.             MaxHeight = TmpHeight
  45.         End If
  46.     Next i
  47.  
  48.     LinesAvailable = ControlVerticalSpace / MaxHeight
  49.     SpaceLeft = LinesAvailable * ControlHorizontalSpace             ' Space left to get words in
  50.  
  51.     ActualTextWidth = fTextWidth(Ctl, ActualText)                   ' Get the width of the caption
  52.     ActualTextHeight = fTextHeight(Ctl, ActualText)                 ' Get the Height of the caption
  53.     LineTextWidth = fTextWidth(Ctl, LineText)                       ' Get the width of the caption without line feeds
  54.     SpaceWidth = fTextWidth(Ctl, " ")                               ' Get the width of a space
  55.  
  56.     'Stop
  57.  
  58.     If ActualTextWidth < SpaceLeft Then                             ' Enough space for caption
  59.         Exit Sub
  60.     Else                                                            ' Not enough space
  61.         If Ctl.FontSize > TempVars!PP_ResizeFont Then               ' Are we at the mininum size font
  62.         Ctl.FontSize = Ctl.FontSize - 1                             ' Reduce it by 1
  63.         GoTo GetLineLengths                                         ' And see if it fits
  64.         End If
  65.     End If
  66.  
  67.     LastWord = 0
  68.     TotalLength = 0
  69.     FirstWord = LastWord                                            ' Where we started this scan
  70. GetNextLine:
  71.     ' Add the words until we get too long
  72.     i = FirstWord
  73.  
  74.     Do While i <= UBound(Words) And TotalLength < ControlHorizontalSpace
  75.         TotalLength = TotalLength + WordWidths(i) + SpaceWidth
  76.         i = i + 1
  77.     Loop
  78.  
  79.     TotalLength = TotalLength - SpaceWidth                          ' Remove length of final space
  80.     LastWord = i - 1                                                ' Last word that wil fit
  81.  
  82.     If LastWord > 0 Then
  83.         If LastWord = UBound(Words) Then                            ' Last word
  84.             LastWord = LastWord + 1
  85.         End If
  86.  
  87.         For m = FirstWord To LastWord - 1
  88.             NewCaption = NewCaption & Words(m) & vbCrLf             ' Words that will fit + line feed
  89.             TotalLength = TotalLength - WordWidths(m)               ' Reduce the length required by word length
  90.         Next m
  91.         TotalLength = TotalLength - SpaceWidth                      ' Replaces a space with a line feed
  92.         SpaceLeft = SpaceLeft - ControlHorizontalSpace              ' We have used a line up
  93.         FirstWord = LastWord
  94.         If TotalLength < 10 And TotalLength > -10 Then              ' pretty good fit
  95.             Ctl.Caption = NewCaption
  96.             Exit Sub
  97.         End If
  98.         If m >= UBound(Words()) And SpaceLeft >= 0 Then             ' All words done and space to spare
  99.             Ctl.Caption = NewCaption
  100.             Exit Sub
  101.         End If
  102.         GoTo GetNextLine
  103.     Else
  104.         Exit Sub                                                    ' No change
  105.     End If
  106.  
  107. End Sub
  108.  
Thanks for your input


Phil
Oct 1 '17 #10

ADezii
Expert 5K+
P: 8,623
The parameters in a way are very simple. Given a label of fixed size and font characteristics other than font size (including name, bold, italic etc), and given the caption that has to fit in the label, working down from the original font size, what is the maximum font size we can get without dropping below say 7 points to get the caption to fit the label?
Keeping more closely in mind the above, I made a couple of minor changes. See what you think.
Attached Files
File Type: zip MAX Font Size_2.zip (24.3 KB, 44 views)
Oct 2 '17 #11

PhilOfWalton
Expert 100+
P: 1,430
Thanks again for trying, but as you see in this image, I have made the text box narrower, and taller. Obviously the font could be much bigger and the message spread over 3 or 4 lines



I think I will stick to my horrible spaghetti code as it seems to work reasonably reliably, but I really do appreciate your help

Phil
Oct 4 '17 #12

Post your reply

Sign in to post your reply or Sign up for a free account.