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 -
Function ShrinkFont(Ctl As Control)
-
-
'See if the text will fit the in the label or command button
-
' Note that a line feed in a caplion is Chr(13) & Chr$(10) = vbCrLf
-
Dim TextWidth As Long
-
Dim TextHeight As Long
-
TextWidth = fTextWidth(Ctl, Ctl.Caption) ' Get the width of the caption
-
TextHeight = fTextHeight(Ctl, Ctl.Caption) ' Get the Height of the caption
-
-
' Control too narrow, so must shrink font (if neccessary) Need to see if there is a spare line
-
Do Until TextWidth < Ctl.Width
-
TextWidth = fTextWidth(Ctl, Ctl.Caption)
-
Ctl.FontSize = Ctl.FontSize - 1
-
If Ctl.FontSize < TempVars!PP_ResizeFont Then ' Too small
-
Exit Do
-
End If
-
Loop
-
-
End Function
-
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
11 4684 NeoPa 32,556
Expert Mod 16PB
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.
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) -
Option Compare Database
-
Option Explicit
-
-
Private Type RECT
-
Left As Long
-
Top As Long
-
Right As Long
-
Bottom As Long
-
End Type
-
-
Private Const LF_FACESIZE = 32
-
-
Private Type LOGFONT
-
lfHeight As Long
-
lfWidth As Long
-
lfEscapement As Long
-
lfOrientation As Long
-
lfWeight As Long
-
lfItalic As Byte
-
lfUnderline As Byte
-
lfStrikeOut As Byte
-
lfCharSet As Byte
-
lfOutPrecision As Byte
-
lfClipPrecision As Byte
-
lfQuality As Byte
-
lfPitchAndFamily As Byte
-
lfFaceName As String * LF_FACESIZE
-
End Type
-
-
Private Type TEXTMETRIC
-
tmHeight As Long
-
tmAscent As Long
-
tmDescent As Long
-
tmInternalLeading As Long
-
tmExternalLeading As Long
-
tmAveCharWidth As Long
-
tmMaxCharWidth As Long
-
tmWeight As Long
-
tmOverhang As Long
-
tmDigitizedAspectX As Long
-
tmDigitizedAspectY As Long
-
tmFirstChar As Byte
-
tmLastChar As Byte
-
tmDefaultChar As Byte
-
tmBreakChar As Byte
-
tmItalic As Byte
-
tmUnderlined As Byte
-
tmStruckOut As Byte
-
tmPitchAndFamily As Byte
-
tmCharSet As Byte
-
End Type
-
-
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" _
-
(ByVal hDC As Long, lpMetrics As TEXTMETRIC) As Long
-
-
Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
-
"CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
-
-
Private Declare Function apiSelectObject Lib "gdi32" Alias "SelectObject" _
-
(ByVal hDC As Long, _
-
ByVal hObject As Long) As Long
-
-
Private Declare Function apiDeleteObject Lib "gdi32" _
-
Alias "DeleteObject" (ByVal hObject As Long) As Long
-
-
Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
-
(ByVal hDC As Long, ByVal nIndex As Long) As Long
-
-
Private Declare Function apiMulDiv Lib "kernel32" Alias "MulDiv" _
-
(ByVal nNumber As Long, _
-
ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
-
-
Private Declare Function apiGetDC Lib "user32" _
-
Alias "GetDC" (ByVal hwnd As Long) As Long
-
-
Private Declare Function apiReleaseDC Lib "user32" _
-
Alias "ReleaseDC" (ByVal hwnd As Long, _
-
ByVal hDC As Long) As Long
-
-
Private Declare Function apiDrawText Lib "user32" Alias "DrawTextA" _
-
(ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, _
-
lpRect As RECT, ByVal wFormat As Long) As Long
-
-
Private Declare Function CreateDCbyNum Lib "gdi32" Alias "CreateDCA" _
-
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
-
ByVal lpOutput As Long, ByVal lpInitData As Long) As Long 'DEVMODE) As Long
-
-
Private Declare Function apiDeleteDC Lib "gdi32" _
-
Alias "DeleteDC" (ByVal hDC As Long) As Long
-
-
Declare Function GetProfileString Lib "kernel32" _
-
Alias "GetProfileStringA" _
-
(ByVal lpAppName As String, _
-
ByVal lpKeyName As String, _
-
ByVal lpDefault As String, _
-
ByVal lpReturnedString As String, _
-
ByVal nSize As Long) As Long
-
-
-
-
-
' CONSTANTS
-
Private Const TWIPSPERINCH = 1440
-
' Used to ask System for the Logical pixels/inch in X & Y axis
-
Private Const LOGPIXELSY = 90
-
Private Const LOGPIXELSX = 88
-
-
' DrawText() Format Flags
-
Private Const DT_TOP = &H0
-
Private Const DT_LEFT = &H0
-
Private Const DT_CALCRECT = &H400
-
Private Const DT_WORDBREAK = &H10
-
Private Const DT_EXTERNALLEADING = &H200
-
Private Const DT_EDITCONTROL = &H2000&
-
-
-
' Font stuff
-
Private Const OUT_DEFAULT_PRECIS = 0
-
Private Const OUT_STRING_PRECIS = 1
-
Private Const OUT_CHARACTER_PRECIS = 2
-
Private Const OUT_STROKE_PRECIS = 3
-
Private Const OUT_TT_PRECIS = 4
-
Private Const OUT_DEVICE_PRECIS = 5
-
Private Const OUT_RASTER_PRECIS = 6
-
Private Const OUT_TT_ONLY_PRECIS = 7
-
Private Const OUT_OUTLINE_PRECIS = 8
-
-
Private Const CLIP_DEFAULT_PRECIS = 0
-
Private Const CLIP_CHARACTER_PRECIS = 1
-
Private Const CLIP_STROKE_PRECIS = 2
-
Private Const CLIP_MASK = &HF
-
Private Const CLIP_LH_ANGLES = 16
-
Private Const CLIP_TT_ALWAYS = 32
-
Private Const CLIP_EMBEDDED = 128
-
-
Private Const DEFAULT_QUALITY = 0
-
Private Const DRAFT_QUALITY = 1
-
Private Const PROOF_QUALITY = 2
-
-
Private Const DEFAULT_PITCH = 0
-
Private Const FIXED_PITCH = 1
-
Private Const VARIABLE_PITCH = 2
-
-
Private Const ANSI_CHARSET = 0
-
Private Const DEFAULT_CHARSET = 1
-
Private Const SYMBOL_CHARSET = 2
-
Private Const SHIFTJIS_CHARSET = 128
-
Private Const HANGEUL_CHARSET = 129
-
Private Const CHINESEBIG5_CHARSET = 136
-
Private Const OEM_CHARSET = 255
-
'
-
-
Public Function fTextHeight(Ctl As Control, _
-
Optional ByVal sText As String = "", _
-
Optional HeightTwips As Long = 0, Optional WidthTwips As Long = 0, _
-
Optional TotalLines As Long = 0) As Long
-
-
On Error Resume Next
-
-
' Call our function to calculate TextHeight
-
' If blWH=TRUE then we are TextHeight
-
fTextHeight = fTextWidthOrHeight(Ctl, True, _
-
sText, HeightTwips, WidthTwips, TotalLines)
-
-
End Function
-
-
-
Public Function fTextWidth(Ctl As Control, _
-
Optional ByVal sText As String = "", _
-
Optional HeightTwips As Long = 0, Optional WidthTwips As Long = 0, _
-
Optional TotalLines As Long = 0) As Long
-
-
On Error Resume Next
-
-
' If blWH=FALSE then we are TextWidth
-
' Call our function to calculate TextWidth
-
fTextWidth = fTextWidthOrHeight(Ctl, False, _
-
sText, HeightTwips, WidthTwips)
-
-
End Function
-
-
-
Public Function fTextWidthOrHeight(Ctl As Control, ByVal blWH As Boolean, _
-
Optional ByVal sText As String = "", _
-
Optional HeightTwips As Long = 0, Optional WidthTwips As Long = 0, _
-
Optional TotalLines As Long = 0) As Long
-
-
'Name FUNCTION() fTextWidthOrHeight
-
'
-
-
'Purpose: Returns the Height or Width needed to
-
' display the contents of the Control passed
-
' to this function. This function
-
' uses the Control's font attributes to build
-
' a Font for the required calculations.
-
'
-
' This function replaces the Report object's TextHeight
-
' and TextWidth methods which only work for a single line of text.
-
' This function works with multiple lines of text and
-
' also with both Forms and Reports.
-
'
-
'Version: 4.1
-
'
-
'Calls: Text API stuff. DrawText performs the actual
-
' calculation to determine Control Height.
-
'
-
'Returns: Height or width of Control in TWIPS required
-
' to display current contents.
-
'
-
'Created by: Stephen Lebans
-
'
-
'Credits: If you want some...take some.
-
'
-
'Date: May 22, 2001
-
'
-
'Time: 10:10:10pm
-
'
-
'Feedback: Stephen@lebans.com
-
'
-
'My Web Page: www.lebans.com
-
'
-
'Copyright: Lebans Holdings Ltd.
-
' Please feel free to use this code
-
' without restriction in any application you develop.
-
' This code may not be resold by itself or as
-
' part of a collection.
-
'
-
'What's Missing: Let me know!
-
'
-
'
-
'
-
'Bugs:
-
'None at this point.
-
'
-
'Enjoy
-
'Stephen Lebans
-
-
'***************Code Start***************
-
-
' Structure for DrawText calc
-
Dim sRect As RECT
-
-
' Reports Device Context
-
Dim hDC As Long
-
-
' Holds the current screen resolution
-
Dim lngDPI As Long
-
-
Dim newfont As Long
-
' Handle to our Font Object we created.
-
' We must destroy it before exiting main function
-
-
Dim oldfont As Long
-
' Device COntext's Font we must Select back into the DC
-
' before we exit this function.
-
-
' Temporary holder for returns from API calls
-
Dim lngRet As Long
-
-
' Logfont struct
-
Dim myfont As LOGFONT
-
-
' TextMetric struct
-
Dim tm As TEXTMETRIC
-
-
' LineSpacing Amount
-
Dim lngLineSpacing As Long
-
-
' Ttemp var
-
Dim numLines As Long
-
-
' Temp string var for current printer name
-
Dim strName As String
-
-
On Error GoTo Err_Handler
-
-
' If we are being called from a Form then SKIP
-
' the logic to Create a Printer DC and simply use
-
' the Screen's DC
-
-
If TypeOf Ctl.Parent Is Access.Report Then
-
' ***************************************************
-
' Warning! Do not use Printer's Device Context for Forms.
-
' This alternative is meant for Report's only!!!!!
-
' For a Report the best accuracy is obtained if you get a handle to
-
' the printer's Device Context instead of the Screen's.
-
' You can uncomment his code and comment out the
-
' apiGetDc line of code.
-
' We need to use the Printer's Device Context
-
' in order to more closely match Font height calcs
-
' with actual ouptut. This example simply uses the
-
' default printer for the system. You could also
-
' add logic to use the Devnames property if this
-
' report prints to a specific printer.
-
strName = GetDefaultPrintersName
-
hDC = CreateDCbyNum("WINSPOOL", strName, 0&, 0&)
-
If hDC = 0 Then
-
' Error cannot get handle to printer Device Context
-
Err.Raise vbObjectError + 255, "fTextWidthOrHeight", "Cannot Create Printer DC"
-
End If
-
' ***************************************************
-
Else
-
' Get handle to screen Device Context
-
hDC = apiGetDC(0&)
-
End If
-
-
' Were we passed a valid string
-
If Len(sText & vbNullString) = 0 Then
-
' Did we get a valid control passed to us?
-
'select case typeof ctl is
-
Select Case Ctl.ControlType
-
-
Case acTextBox
-
sText = Nz(Ctl.Value, vbNullString)
-
-
'~~~~Case acLabel, acCommandButton, acPage
-
-
Case acLabel, acPage, acToggleButton, acCommandButton
-
sText = Nz(Ctl.Caption, vbNullString)
-
-
Case Else
-
' Fail - not a control we can work with
-
fTextWidthOrHeight = 0
-
Exit Function
-
End Select
-
End If
-
-
-
' Get current device resolution
-
' blWH=TRUE then we are TextHeight
-
If blWH Then
-
lngDPI = apiGetDeviceCaps(hDC, LOGPIXELSY)
-
Else
-
lngDPI = apiGetDeviceCaps(hDC, LOGPIXELSX)
-
End If
-
-
' We use a negative value to signify
-
' to the CreateFont function that we want a Glyph
-
' outline of this size not a bounding box.
-
' Copy font stuff from Text Control's property sheet
-
With Ctl
-
myfont.lfClipPrecision = CLIP_LH_ANGLES
-
myfont.lfOutPrecision = OUT_TT_ONLY_PRECIS
-
myfont.lfEscapement = 0
-
If Ctl.ControlType = acPage Then
-
myfont.lfFaceName = Ctl.Parent.FontName & Chr$(0)
-
myfont.lfWeight = Ctl.Parent.FontWeight
-
myfont.lfItalic = Ctl.Parent.FontItalic
-
myfont.lfUnderline = Ctl.Parent.FontUnderline
-
'Must be a negative figure for height or system will return
-
'closest match on character cell not glyph
-
myfont.lfHeight = (Ctl.Parent.FontSize / 72) * -lngDPI
-
' Create our temp font
-
newfont = apiCreateFontIndirect(myfont)
-
Else
-
myfont.lfFaceName = .FontName & Chr$(0)
-
myfont.lfWeight = .FontWeight
-
myfont.lfItalic = .FontItalic
-
myfont.lfUnderline = .FontUnderline
-
'Must be a negative figure for height or system will return
-
'closest match on character cell not glyph
-
myfont.lfHeight = (.FontSize / 72) * -lngDPI
-
' Create our temp font
-
newfont = apiCreateFontIndirect(myfont)
-
End If
-
End With
-
-
If newfont = 0 Then
-
Err.Raise vbObjectError + 256, "fTextWidthOrHeight", "Cannot Create Font"
-
End If
-
-
' Select the new font into our DC.
-
oldfont = apiSelectObject(hDC, newfont)
-
-
' Use DrawText to Calculate height of Rectangle required to hold
-
' the current contents of the Control passed to this function.
-
-
With sRect
-
.Left = 0
-
.Top = 0
-
.Bottom = 0
-
' blWH=TRUE then we are TextHeight
-
If blWH Then
-
.Right = (Ctl.Width / (TWIPSPERINCH / lngDPI)) - 10
-
Else
-
' Single line TextWidth
-
.Right = 32000
-
End If
-
-
' Calculate our bounding box based on the controls current width
-
lngRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or _
-
DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL)
-
-
' Get TextMetrics. This is required to determine
-
' Text height and the amount of extra spacing between lines.
-
lngRet = GetTextMetrics(hDC, tm)
-
-
' Cleanup
-
lngRet = apiSelectObject(hDC, oldfont)
-
' Delete the Font we created
-
apiDeleteObject (newfont)
-
-
If TypeOf Ctl.Parent Is Access.Report Then
-
' ***************************************************
-
' If you are using the Printers' DC then uncomment below
-
' and comment out the apiReleaseDc line of code below
-
' Delete our handle to the Printer DC
-
lngRet = apiDeleteDC(hDC)
-
' ***************************************************
-
Else
-
' Release the handle to the Screen's DC
-
lngRet = apiReleaseDC(0&, hDC)
-
End If
-
-
' Calculate how many lines we are displaying
-
' return to calling function. The GDI incorrectly
-
' calculates the bounding rectangle because
-
' of rounding errors converting to Integers.
-
TotalLines = .Bottom / (tm.tmHeight + tm.tmExternalLeading)
-
numLines = TotalLines
-
-
' Convert RECT values to TWIPS
-
.Bottom = (.Bottom) * (TWIPSPERINCH / lngDPI)
-
-
' ***************************************************
-
' For A2K only!
-
' Now we need to add in the amount of the
-
' line spacing property.
-
'lngLineSpacing = ctl.LineSpacing * (numLines - 1)
-
'If numLines = 1 Then lngLineSpacing = lngLineSpacing + (ctl.LineSpacing / 2)
-
' Increase our control's height accordingly
-
'.Bottom = .Bottom + lngLineSpacing
-
-
-
' Return values in optional vars
-
' Convert RECT Pixel values to TWIPS
-
HeightTwips = .Bottom '* (TWIPSPERINCH / lngDPI)
-
WidthTwips = .Right * (TWIPSPERINCH / lngDPI) '(apiGetDeviceCaps(hDC, LOGPIXELSX)))
-
-
' blWH=TRUE then we are TextHeight
-
If blWH Then
-
fTextWidthOrHeight = HeightTwips
-
Else
-
fTextWidthOrHeight = WidthTwips
-
End If
-
End With
-
-
' Exit normally
-
Exit_OK:
-
Exit Function
-
-
Err_Handler:
-
Err.Raise Err.Source, Err.Number, Err.Description
-
Resume Exit_OK
-
End Function
-
-
Function GetDefaultPrintersName() As String
-
' This function is from Peter Walker.
-
' Check out his web site at:
-
' http://www.users.bigpond.com/papwalker/
-
Dim success As Long
-
Dim nSize As Long
-
Dim lpKeyName As String
-
Dim ret As String
-
Dim posDriver
-
'call the API passing null as the parameter
-
'for the lpKeyName parameter. This causes
-
'the API to return a list of all keys under
-
'that section. Pad the passed string large
-
'enough to hold the data. Adjust to suit.
-
ret = Space$(8102)
-
nSize = Len(ret)
-
success = GetProfileString("windows", "device", "", ret, nSize)
-
posDriver = InStr(ret, ",")
-
GetDefaultPrintersName = Left$(ret, posDriver - 1)
-
End Function
-
-
Sub ShrinkFont(Ctl As Control)
-
'See if the text will fit the in the label or command button
-
' Note that a line feed in a caplion is Chr(13) & Chr$(10) = vbCrLf
-
Dim ActualText As String
-
Dim ActualTextWidth As Long
-
Dim ActualTextHeight As Long
-
Dim LineText As String ' Text after reoving VbCrLf
-
Dim LineTextWidth As Long ' Width of single line after reoving VbCrLf
-
Dim CtlArea As Long
-
Dim TextArea As Long
-
Dim Words() As String
-
Dim WordWidths() As Long
-
Dim MaxHeight As Long
-
Dim TmpHeight As Long
-
Dim i As Integer, LastWord As Integer, FirstWord As Integer, m As Integer
-
Dim LinesAvailable As Integer
-
Dim ControlVerticalSpace As Long
-
Dim ControlHorizontalSpace As Long
-
Dim SpaceWidth As Long
-
Dim TotalLength As Long
-
Dim NewCaption As String
-
Dim SpaceLeft As Long
-
-
ControlVerticalSpace = Ctl.Height - (Ctl.TopPadding + Ctl.BottomPadding)
-
ControlHorizontalSpace = Ctl.Width - (Ctl.LeftPadding + Ctl.RightPadding)
-
-
ActualText = Ctl.Caption
-
LineText = Replace(Ctl.Caption, Chr$(34) & Chr$(10), " ") ' Rmove line feeds
-
Words = Split(LineText, " ") ' Get each individual word
-
ReDim WordWidths(UBound(Words))
-
-
GetLineLengths:
-
NewCaption = ""
-
MaxHeight = 0
-
For i = 0 To UBound(Words)
-
WordWidths(i) = fTextWidth(Ctl, Words(i))
-
TmpHeight = fTextHeight(Ctl, Words(i)) ' Maximum height of any word
-
If TmpHeight > MaxHeight Then
-
MaxHeight = TmpHeight
-
End If
-
Next i
-
-
LinesAvailable = ControlVerticalSpace / MaxHeight
-
SpaceLeft = LinesAvailable * ControlHorizontalSpace ' Space left to get words in
-
-
ActualTextWidth = fTextWidth(Ctl, ActualText) ' Get the width of the caption
-
ActualTextHeight = fTextHeight(Ctl, ActualText) ' Get the Height of the caption
-
LineTextWidth = fTextWidth(Ctl, LineText) ' Get the width of the caption without line feeds
-
SpaceWidth = fTextWidth(Ctl, " ") ' Get the width of a space
-
-
'Stop
-
-
If ActualTextWidth < SpaceLeft Then ' Enough space for caption
-
Exit Sub
-
Else ' Not enough space
-
If Ctl.FontSize > TempVars!PP_ResizeFont Then ' Are we at the mininum size font
-
Ctl.FontSize = Ctl.FontSize - 1 ' Reduce it by 1
-
GoTo GetLineLengths ' And see if it fits
-
End If
-
End If
-
-
LastWord = 0
-
TotalLength = 0
-
FirstWord = LastWord ' Where we started this scan
-
GetNextLine:
-
' Add the words until we get too long
-
i = FirstWord
-
-
Do While i <= UBound(Words) And TotalLength < ControlHorizontalSpace
-
TotalLength = TotalLength + WordWidths(i) + SpaceWidth
-
i = i + 1
-
Loop
-
-
TotalLength = TotalLength - SpaceWidth ' Remove length of final space
-
LastWord = i - 1 ' Last word that wil fit
-
-
If LastWord > 0 Then
-
If LastWord = UBound(Words) Then ' Last word
-
LastWord = LastWord + 1
-
End If
-
-
For m = FirstWord To LastWord - 1
-
NewCaption = NewCaption & Words(m) & vbCrLf ' Words that will fit + line feed
-
TotalLength = TotalLength - WordWidths(m) ' Reduce the length required by word length
-
Next m
-
TotalLength = TotalLength - SpaceWidth ' Replaces a space with a line feed
-
SpaceLeft = SpaceLeft - ControlHorizontalSpace ' We have used a line up
-
FirstWord = LastWord
-
If TotalLength < 10 And TotalLength > -10 Then ' pretty good fit
-
Ctl.Caption = NewCaption
-
Exit Sub
-
End If
-
If m >= UBound(Words()) And SpaceLeft >= 0 Then ' All words done and space to spare
-
Ctl.Caption = NewCaption
-
Exit Sub
-
End If
-
GoTo GetNextLine
-
Else
-
Exit Sub ' No change
-
End If
-
-
End Sub
-
-
Sorry, this is a very long module
Phil
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: - 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).
- Establish the Length of your Label Control in Inches (in this case 7.9167).
- Open the Report in Hidden Mode and place the required Code in the Detail's Print() Event.
- Loop thru a desired Range of Font Sizes (in this case 24 thru 8).
- 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.
- This does not address the Height adjustment, I'll leave that up to you.
- If you are interested in this approach, I'll send you the Demo.
- The results are not perfect, since a Font Size of 20 can actually be used in this scenario, close but no cigar! (LOL).
NeoPa 32,556
Expert Mod 16PB 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.
@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
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.
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
NeoPa 32,556
Expert Mod 16PB 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.
Sorry, ADezii, I missed your post.
Have had look and it appears that the line -
If (dblAvgSize * Len(strTestString)) < Forms![frmListWidth].Width Then
-
Should be -
If (dblAvgSize * Len(strTestString)) < Forms![frmListWidth]!lblItem.Width Then
-
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. -
Sub ShrinkFont(Ctl As Control)
-
'See if the text will fit the in the label or command button
-
' Note that a line feed in a caplion is Chr(13) & Chr$(10) = vbCrLf
-
Dim ActualText As String
-
Dim ActualTextWidth As Long
-
Dim ActualTextHeight As Long
-
Dim LineText As String ' Text after reoving VbCrLf
-
Dim LineTextWidth As Long ' Width of single line after reoving VbCrLf
-
Dim CtlArea As Long
-
Dim TextArea As Long
-
Dim Words() As String
-
Dim WordWidths() As Long
-
Dim MaxHeight As Long
-
Dim TmpHeight As Long
-
Dim i As Integer, LastWord As Integer, FirstWord As Integer, m As Integer
-
Dim LinesAvailable As Integer
-
Dim ControlVerticalSpace As Long
-
Dim ControlHorizontalSpace As Long
-
Dim SpaceWidth As Long
-
Dim TotalLength As Long
-
Dim NewCaption As String
-
Dim SpaceLeft As Long
-
-
If Ctl.ControlType = acPage Then ' Pages don't have padding
-
ControlVerticalSpace = Ctl.Height
-
ControlHorizontalSpace = Ctl.Width
-
Else
-
ControlVerticalSpace = Ctl.Height - (Ctl.TopPadding + Ctl.BottomPadding)
-
ControlHorizontalSpace = Ctl.Width - (Ctl.LeftPadding + Ctl.RightPadding)
-
End If
-
-
ActualText = Ctl.Caption
-
LineText = Replace(Ctl.Caption, Chr$(34) & Chr$(10), " ") ' Rmove line feeds
-
Words = Split(LineText, " ") ' Get each individual word
-
ReDim WordWidths(UBound(Words))
-
-
GetLineLengths:
-
NewCaption = ""
-
MaxHeight = 0
-
For i = 0 To UBound(Words)
-
WordWidths(i) = fTextWidth(Ctl, Words(i))
-
TmpHeight = fTextHeight(Ctl, Words(i)) ' Maximum height of any word
-
If TmpHeight > MaxHeight Then
-
MaxHeight = TmpHeight
-
End If
-
Next i
-
-
LinesAvailable = ControlVerticalSpace / MaxHeight
-
SpaceLeft = LinesAvailable * ControlHorizontalSpace ' Space left to get words in
-
-
ActualTextWidth = fTextWidth(Ctl, ActualText) ' Get the width of the caption
-
ActualTextHeight = fTextHeight(Ctl, ActualText) ' Get the Height of the caption
-
LineTextWidth = fTextWidth(Ctl, LineText) ' Get the width of the caption without line feeds
-
SpaceWidth = fTextWidth(Ctl, " ") ' Get the width of a space
-
-
'Stop
-
-
If ActualTextWidth < SpaceLeft Then ' Enough space for caption
-
Exit Sub
-
Else ' Not enough space
-
If Ctl.FontSize > TempVars!PP_ResizeFont Then ' Are we at the mininum size font
-
Ctl.FontSize = Ctl.FontSize - 1 ' Reduce it by 1
-
GoTo GetLineLengths ' And see if it fits
-
End If
-
End If
-
-
LastWord = 0
-
TotalLength = 0
-
FirstWord = LastWord ' Where we started this scan
-
GetNextLine:
-
' Add the words until we get too long
-
i = FirstWord
-
-
Do While i <= UBound(Words) And TotalLength < ControlHorizontalSpace
-
TotalLength = TotalLength + WordWidths(i) + SpaceWidth
-
i = i + 1
-
Loop
-
-
TotalLength = TotalLength - SpaceWidth ' Remove length of final space
-
LastWord = i - 1 ' Last word that wil fit
-
-
If LastWord > 0 Then
-
If LastWord = UBound(Words) Then ' Last word
-
LastWord = LastWord + 1
-
End If
-
-
For m = FirstWord To LastWord - 1
-
NewCaption = NewCaption & Words(m) & vbCrLf ' Words that will fit + line feed
-
TotalLength = TotalLength - WordWidths(m) ' Reduce the length required by word length
-
Next m
-
TotalLength = TotalLength - SpaceWidth ' Replaces a space with a line feed
-
SpaceLeft = SpaceLeft - ControlHorizontalSpace ' We have used a line up
-
FirstWord = LastWord
-
If TotalLength < 10 And TotalLength > -10 Then ' pretty good fit
-
Ctl.Caption = NewCaption
-
Exit Sub
-
End If
-
If m >= UBound(Words()) And SpaceLeft >= 0 Then ' All words done and space to spare
-
Ctl.Caption = NewCaption
-
Exit Sub
-
End If
-
GoTo GetNextLine
-
Else
-
Exit Sub ' No change
-
End If
-
-
End Sub
-
Thanks for your input
Phil
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.
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
Sign in to post your reply or Sign up for a free account.
Similar topics
by: kmunderwood |
last post by:
I am having trouble changing the font size when extracting xml into an
html web page.
I think it can be done so many ways, that my searches bring up examples
that I am not familiar with.
I am a...
|
by: Coder Droid |
last post by:
I'm trying my first table-less site, and I've bumped my head up against
a wall. I can't change the font size within a div.
Real quick, my style sheet has:
-------------------------------------...
|
by: lharby |
last post by:
Basic question, is this possible?
I have managed to crib a javascript function that allows the user to
increase or decrease the font size of a page. (see...
|
by: Bjoern |
last post by:
Hi all,
how can i change the Font Size of the Text in my Label.
I will change it dynamic in the code.
I tryed:
int number = 11;
label1.Font.Size = number;
But this is not possible because Size...
|
by: VB Programmer |
last post by:
How can I change the font size of a text box dynamically?
I tried this but it didn't work. It said 'Size is Read-Only'. Any other
ways around this? Here's the code:
txtDisplay.Font.Size = 10
|
by: Dave |
last post by:
How can I change the font size of a label?
I have:
Label1.Font.Size = "12"
but it's telling me that property 'Size' is readonly.
Thanks,
|
by: ken |
last post by:
Hi,
How do you change the font for the data labels on your bar graph
report/chart? I have 24 series, and when I change the font of the data
label for one series that does not change them all......
|
by: # Cyrille37 # |
last post by:
Hello,
Font.Size Property is readonly.
How can I change the Size of a Font ???
Thanks for your help
cyrille
|
by: _Who |
last post by:
I spent all day yesterday trying different things.
Something has happened so I can't change font size.
I have a table and in the first cell I have only text.
I tried using the cell's Style...
|
by: reyo |
last post by:
Hi,
i design a dynamic web page.infact it will be a css generator.
i have a question about visited link.
i want to change color,font-size,font-weight etc. of a link when it is visited.
when a...
|
by: taylorcarr |
last post by:
A Canon printer is a smart device known for being advanced, efficient, and reliable. It is designed for home, office, and hybrid workspace use and can also be used for a variety of purposes. However,...
|
by: aa123db |
last post by:
Variable and constants
Use var or let for variables and const fror constants.
Var foo ='bar';
Let foo ='bar';const baz ='bar';
Functions
function $name$ ($parameters$) {
}
...
|
by: ryjfgjl |
last post by:
If we have dozens or hundreds of excel to import into the database, if we use the excel import function provided by database editors such as navicat, it will be extremely tedious and time-consuming...
|
by: emmanuelkatto |
last post by:
Hi All, I am Emmanuel katto from Uganda. I want to ask what challenges you've faced while migrating a website to cloud.
Please let me know.
Thanks!
Emmanuel
|
by: BarryA |
last post by:
What are the essential steps and strategies outlined in the Data Structures and Algorithms (DSA) roadmap for aspiring data scientists? How can individuals effectively utilize this roadmap to progress...
|
by: Sonnysonu |
last post by:
This is the data of csv file
1 2 3
1 2 3
1 2 3
1 2 3
2 3
2 3
3
the lengths should be different i have to store the data by column-wise with in the specific length.
suppose the i have to...
|
by: marktang |
last post by:
ONU (Optical Network Unit) is one of the key components for providing high-speed Internet services. Its primary function is to act as an endpoint device located at the user's premises. However,...
|
by: Oralloy |
last post by:
Hello folks,
I am unable to find appropriate documentation on the type promotion of bit-fields when using the generalised comparison operator "<=>".
The problem is that using the GNU compilers,...
|
by: jinu1996 |
last post by:
In today's digital age, having a compelling online presence is paramount for businesses aiming to thrive in a competitive landscape. At the heart of this digital strategy lies an intricately woven...
| |