422,904 Members | 1,025 Online
Bytes IT Community
+ Ask a Question
Need help? Post your question and get tips & solutions from a community of 422,904 IT Pros & Developers. It's quick & easy.

How to Shrink text to fit in the text box in MS Access report

P: 83
I have a text box on a report that has height to show two lines of text. Is there any way to shrink the font size to fit the height of the text box? I have seen a code on this forum that shrinks the text font size to show the text in a single line that becomes too small to be read easily.

Any help please.
1 Days ago #1
Share this Question
Share on Google+
4 Replies


twinnyfo
Expert Mod 100+
P: 2,415
The solution you describes is exactly why this is not a good idea. You should build the size of your text boxes so that they are large enough to fit the text you are working with. You can also have the text box with the property of CanGrow = True, and then its height will change if the text is too large.
1 Days ago #2

P: 83
Thank you for quick response. Actually I am already using the "can grow" property for number of reports. However, if I have to print Data-only on to a pre-printed form/paper then I have to fix the height of the text box accordingly and most of the data does not exceed the dimensions of the text boxes. However, only in rare cases, a specific field may expectedly exceed by a few characters. When I use the method to shrink text to fit in the text box as described here, the text shrinks too much to be read easily. Is there any way to overcome these situations?
1 Days ago #3

PhilOfWalton
Expert 100+
P: 1,183
This is very complicated, largely written by the late & great Stephen Lebans, with additions by myself.

The background is that I have an Access program that will translate a client's program into pretty well any language you choose. Frequently the client has been mean with the space allowed for labels, for example "pig" in English, "schwein" in German, so if the label fits "pig", I have to shrink the font to get in "schwein".

There is a lower limit (7 points) defined in TempVars!DbT_ResizeFont

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

Phil
1 Days ago #4

twinnyfo
Expert Mod 100+
P: 2,415
As usual, Phil has an excellent solution. Unfortunately, if the text does not fit with the smallest allowable font, that field will be truncated—that’s all there is to it.

The only other guideline I can provide it that you can also limit the number of characters allowed in a particular text field, so that users don’t exceed the size of the text box.

Phil’s solution provides the most flexibility, but greater overhead in programming; the above solution is very simple, but significantly limits the contents of your text field.
1 Days ago #5

Post your reply

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