Option Compare Database
Option Explicit
Public DbT_ResizeFont As TempVar ' If > 0, will shrink font to fit available size
' limited by vallue of DbT_ResizeFont (7 seems good)
' If 0 won't shrink font
Private Const LanguageCode = "en"
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.
' #@@@@@ Temporarily set the Default printer to One Note 2016 for this Computer @@@@@
' @@@@@@ Because there is no default printer configures and hdc = 0 @@@@@
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 caption 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 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
On Error GoTo ShrinkFont_Err
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
If Nz(ActualText) = "" Then ' Blank, so nothing to do
GoTo ShrinkFont_Exit
End If
LineText = Replace(Ctl.Caption, Chr$(34) & Chr$(10), " ") ' Remove 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 > CInt(TempVars!DbT_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
If Ctl.FontSize = CInt(TempVars!DbT_ResizeFont) Then ' Small as we can go
Exit Sub
End If
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
ShrinkFont_Exit:
Exit Sub
ShrinkFont_Err:
LogError Err, Err.Description, "ShrinkFont", Erl
End Sub
Comment