This week I’ve been dealing with Fonts. I need it for my new “creature” related to road signaling.
There are a lot of API functions out there that can be put to some use, and not that little are quite difficult to get documented properly from web queries.
These are part of my efforts…
If you need more information about the height and weight of fonts, you should consider to take a look at this Microsoft pages: https://docs.microsoft.com/en-us/windows/win32/gdi/string-widths-and-heights and https://docs.microsoft.com/en-us/windows/win32/gdi/character-widths
Let’s get started.
First of all, the declarations part, where I have fought a lot to get managed with StdFonts and LogFonts (I suspect the name came from Logical fonts).
Here are a bunch of API declarations needed (some of them) to get the thing properly working:
In the following code, to be used on a UserForm, will get the dimensions.
We need a device content (container) to link the fonts to. One important issue is that we need to destroy the DC created once used, because there is a memory leak on the GetDC function (is not destroyed after terminating the UserForm).
Paste in the userform module:
The A spacing is the width to add to the current position before placing the character. The B spacing is the width of the character itself. The C spacing is the white space to the right of the character. The total advance width is determined by calculating the sum of A+B+C. The character cell is an imaginary rectangle that surrounds each character or symbol in a font. Because characters can overhang or underhang the character cell, either or both of the A and C increments can be a negative number.
Remember that the returned items are in pixels linked to the device content so, to get them in cm/mm/inches or whatever, you need to divide by GetDeviceCaps(DeskDC, LOGPIXELSY) to get them in inches, and then multiplied by the cm/mm/inch conversion factor
There are a lot of API functions out there that can be put to some use, and not that little are quite difficult to get documented properly from web queries.
These are part of my efforts…
If you need more information about the height and weight of fonts, you should consider to take a look at this Microsoft pages: https://docs.microsoft.com/en-us/windows/win32/gdi/string-widths-and-heights and https://docs.microsoft.com/en-us/windows/win32/gdi/character-widths
Let’s get started.
First of all, the declarations part, where I have fought a lot to get managed with StdFonts and LogFonts (I suspect the name came from Logical fonts).
Here are a bunch of API declarations needed (some of them) to get the thing properly working:
Option Explicit
'API Declares
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As tPointAPI) As Long
Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal wOptions As Long, ByVal lpRect As Any, ByVal lpString As String, ByVal nCount As Long, lpDX As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RectAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private 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
Private Declare Function GetForegroundWindow Lib "user32" () As Long
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare PtrSafe Function CreateFont Lib "gdi32.dll" Alias "CreateFontA" (ByVal nHeight As Integer, ByVal nWidth As Integer, ByVal nEscapement As Integer, ByVal nOrientation As Integer, ByVal fnWeight As Integer, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As tPointAPI) As Long
Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWndForm As LongPtr, ByVal hDCForm As LongPtr) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef Token As LongPtr, ByRef lpInput As GDIPlusStartupInput, Optional ByVal lpOutputBuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal Token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As LongPtr, ByRef graphics As LongPtr) As Long
Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As LongPtr) As Long
Private Declare PtrSafe Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mSmoothingMode As Long) As Long
Private Declare PtrSafe Function GdipCreatePen1 Lib "GdiPlus.dll" (ByVal mColor As Long, ByVal mWidth As Single, ByVal mUnit As GpUnit, ByRef mPen As LongPtr) As Long
Private Declare PtrSafe Function GdipDeletePen Lib "GdiPlus.dll" (ByVal mPen As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateSolidFill Lib "GdiPlus.dll" (ByVal mColor As Long, ByRef mBrush As LongPtr) As Long
Private Declare PtrSafe Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As LongPtr) As Long
Private Declare PtrSafe Function GdipFillRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mBrush As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare PtrSafe Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mBrush As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare PtrSafe Function GdipDrawLineI Lib "gdiplus" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function GdipDrawRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare PtrSafe Function GdipDrawEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare PtrSafe Function GdipDrawBezierI Lib "gdiplus" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
Private Declare PtrSafe Function Polyline Lib "gdi32" (ByVal hDC As Long, lpPoint As tPointAPI, ByVal nCount As Long) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Boolean
SuppressExternalCodecs As Boolean
End Type
#Else
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function CreateFont Lib "gdi32.dll" Alias "CreateFontA" (ByVal nHeight As Integer, ByVal nWidth As Integer, ByVal nEscapement As Integer, ByVal nOrientation As Integer, ByVal fnWeight As Integer, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As tPointAPI) As Long
Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWndForm As LongPtr, ByVal hDCForm As LongPtr) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef Token As LongPtr, ByRef lpInput As GDIPlusStartupInput, Optional ByVal lpOutputBuf As LongPtr = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal Token As LongPtr) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As LongPtr, ByRef graphics As LongPtr) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mSmoothingMode As Long) As Long
Private Declare Function GdipCreatePen1 Lib "GdiPlus.dll" (ByVal mColor As Long, ByVal mWidth As Single, ByVal mUnit As GpUnit, ByRef mPen As Long) As Long
Private Declare Function GdipDeletePen Lib "GdiPlus.dll" (ByVal mPen As Long) As Long
Private Declare Function GdipCreateSolidFill Lib "GdiPlus.dll" (ByVal mColor As Long, ByRef mBrush As Long) As Long
Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
Private Declare Function GdipFillRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipDrawLineI Lib "gdiplus" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GdipDrawRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipDrawEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
Private Declare Function GdipDrawBezierI Lib "gdiplus" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
Private Declare Function Polyline Lib "gdi32" (ByVal hDC As Long, lpPoint As tPointAPI, ByVal nCount As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Boolean
SuppressExternalCodecs As Boolean
End Type
#End If
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RectAPI, ByVal wFormat As Long) As Long
Private Const CB_SETDROPPEDWIDTH = &H160
Private Const CB_GETDROPPEDWIDTH = &H15F
Public Enum GpUnit
UnitWorld = 0&
UnitDisplay = 1&
UnitPixel = 2&
UnitPoint = 3&
UnitInch = 4&
UnitDocument = 5&
UnitMillimeter = 6&
End Enum
'Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, ByRef lpRect As RectAPI, ByVal wFormat As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
'Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
'Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
'Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal h As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
'Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
'Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetCharABCWidths Lib "gdi32" Alias "GetCharABCWidthsA" (ByVal hDC As Long, ByVal uFirstChar As Long, ByVal uLastChar As Long, ByRef lpabc As tABC) As Long
Private Declare Function GetCharWidth32 Lib "gdi32" Alias "GetCharWidth32A" (ByVal hDC As Long, ByVal iFirstChar As Long, ByVal iLastChar As Long, ByRef lpBuffer As Long) As Long
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hDC As Long, ByRef lpMetrics As TEXTMETRIC) As Long
Private Declare Function GetCharABCWidthsFloat Lib "gdi32" Alias "GetCharABCWidthsFloatA" (ByVal hDC&, ByVal iFirstChar&, ByVal iLastChar&, ByRef lpABCF As tABCFloat) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
' CONSTANTS
Private Const TWIPSPERINCH As Long = 1440
' Used to ask System for the Logical pixels/inch in X & Y axis
Private Const LOGPIXELSY As Long = 90
Private Const LOGPIXELSX As Long = 88
' DrawText() Format Flags
Private Const DT_SINGLELINE As Long = &H20
Private Const DT_CALCRECT As Long = &H400
Private Const DT_EXTERNALLEADING As Long = &H200
Private Const DT_TOP As Long = &H0
Private Const DT_LEFT As Long = &H0
Private Const DT_EDITCONTROL As Long = &H2000&
Private Const DT_END_ELLIPSIS As Long = &H8000&
Private Const DT_MODIFYSTRING As Long = &H10000
Private Const DT_WORD_ELLIPSIS As Long = &H40000
Private Const DT_WORDBREAK As Long = &H10
' Font stuff
Private Const EM_FMTLINES As Long = &HC8
Private Const SmoothingModeAntiAlias As Long = &H4
Private Const FF_DONTCARE As Long = 0 ' Don't care or don't know.
Private Const LF_FACESIZE As Long = 32
Private Const OUT_DEFAULT_PRECIS As Long = 0
Private Const OUT_STRING_PRECIS As Long = 1
Private Const OUT_CHARACTER_PRECIS As Long = 2
Private Const OUT_STROKE_PRECIS As Long = 3
Private Const OUT_TT_PRECIS As Long = 4
Private Const OUT_DEVICE_PRECIS As Long = 5
Private Const OUT_RASTER_PRECIS As Long = 6
Private Const OUT_TT_ONLY_PRECIS As Long = 7
Private Const OUT_OUTLINE_PRECIS As Long = 8
Private Const CLIP_DEFAULT_PRECIS As Long = 0
Private Const CLIP_CHARACTER_PRECIS As Long = 1
Private Const CLIP_STROKE_PRECIS As Long = 2
Private Const CLIP_MASK As Long = &HF
Private Const CLIP_LH_ANGLES As Long = 16
Private Const CLIP_TT_ALWAYS As Long = 32
Private Const CLIP_EMBEDDED As Long = 128
Private Const DEFAULT_QUALITY As Long = 0
Private Const DRAFT_QUALITY As Long = 1
Private Const PROOF_QUALITY As Long = 2
Private Const DEFAULT_PITCH As Long = 0
Private Const FIXED_PITCH As Long = 1
Private Const VARIABLE_PITCH As Long = 2
Private Const ANSI_CHARSET As Long = 0
Private Const DEFAULT_CHARSET As Long = 1
Private Const SYMBOL_CHARSET As Long = 2
Private Const SHIFTJIS_CHARSET As Long = 128
Private Const HANGEUL_CHARSET As Long = 129
Private Const CHINESEBIG5_CHARSET As Long = 136
Private Const OEM_CHARSET As Long = 255
Private Const TMPF_TRUETYPE As Long = &H4
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 * 32
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 Type tABC
abcA As Long
abcB As Long
abcC As Long
End Type
Private Type tABCFloat
abcfA As Single
abcfB As Single
abcfC As Single
End Type
Private Type RectAPI
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Private hWndForm As LongPtr
Private hDCForm As LongPtr
There are three UDT that are really important here. They are the LOGFONT, the TEXTMETRIC and the tABCFloat.In the following code, to be used on a UserForm, will get the dimensions.
We need a device content (container) to link the fonts to. One important issue is that we need to destroy the DC created once used, because there is a memory leak on the GetDC function (is not destroyed after terminating the UserForm).
Paste in the userform module:
Private Sub UserForm_Initialize()
' Get hWndForm
hWndForm = FindWindow(vbNullString, Me.Caption)
hDCForm = GetDC(hWndForm)
'Get the foreground window's device context
'hWndForm = GetForegroundWindow()
'hDCForm = GetDC(hWndForm )
Dim lgFont As Long
Dim FontSize As Long
Dim FontWeight As Long
Dim FontFaceName As String
Dim mymetrics As TEXTMETRIC
Dim tempDC As Long
Dim tempBMP As Long
' Create a device context and a bitmap that can be used to store a temporary font object
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
' Assign the bitmap to the device context
DeleteObject SelectObject(tempDC, tempBMP)
' ' Capital letters (A - Z) and numbers (0 - 9)in most fonts start a little after the External Leading and extend down
' ' to the Ascent line, and the centre of those characters is usually about 0.48 of the overall "TextHeight" down from
' ' the top of the character cell. The following code will therefore draw a line approximately through the centre
' ' of these characters on most (but not all) fonts.
' The example text is " & fName & " " & Format(fSize, "0.0") & " points"
' Internal Leading = " & InternalLeading & " points"
' Ascent = " & Ascent & " points"
' Descent = " & Descent & " points"
' External Leading = " & ExternalLeading & " points"
' Total Height (Ascent + Descent) = " & Ascent + Descent & " points"
' VB TextHeight returns " & txtHeight & " points"
' The point size is the Ascent plus the Descent
' minus the Internal Leading =
' Me.Print Ascent + Descent - InternalLeading
' Me.FontTransparent = True
' Me.Print
' Internal Leading is from the top down to the yellow line
' Ascent is from the top down to the green line (called the Baseline)
' and it includes the Internal Leading
' Descent is from the green line down to the blue line
' The overall height is equal to Ascent plus
' Descent and is equal to the VB TextHeight
' The point size is from the yellow line down to
' the blue line and is equal to Ascent plus Descent
' minus Internal Leading
' If .tmExternalLeading > 0 Then
' The External Leading is from the blue line to the red line and is ignored."
' Else
' font has zero external leading
' End If
' The white line is typically 0.48 of the TextHeight
' down from the top and runs approximately through the
' centre of capital letters and numerals."
' NOTE: If you use a negative value (normal practice)
' for the desired font size when using the
' CreateFontIndirect API the system will attempt"
' to give you a font where the distance from the yellow
' line to the blue line is equal to the requested value.
' If you use a positive value the"
' system will attempt to give you a font where the overall
' height is equal to the requested value. In both cases
' however all of the above elements "
' will be present. (Using a positive value is effectively
' the same as asking for a slightly smaller font.)"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FontSize = 20 ' in points (72 points/inch)
FontWeight = 400 ' Normal = 400 / Bold = 800
FontFaceName = "Arial"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
lgFont = CreateFont(VBA.CInt(-FontSize), 0, 0, 0, VBA.CInt(FontWeight), 0, 0, 0, 0, 0, 0, 0, 0, FontFaceName) ' LOGPIXELSY = 90, (72 points/inch)
'lgFont = CreateFont(-MulDiv(inFont.Size, GetDeviceCaps(DeskDC, LOGPIXELSY), 72), _
0, -CLng(inAngle * 10), 0, inFont.Weight, inFont.Italic, inFont.Underline, _
inFont.Strikethrough, inFont.Charset, IIf(inOnlyTT, OUT_TT_ONLY_PRECIS, OUT_DEFAULT_PRECIS), _
CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, FF_DONTCARE, inFont.name)
'or: lgFont = CreateFontIndirect(Font)
' Assign the font to the device context
DeleteObject SelectObject(tempDC, lgFont)
GetTextMetrics tempDC, mymetrics
Dim lgChr As Long
Dim aABCFLOAT() As tABCFloat
' Get all with one function:
aABCFLOAT() = GetCharWidths(tempDC)
' Get recursivelly:
' Get UCase chars
ReDim aABCFLOAT(0 To 25)
'Erase aABCFLOAT()
If GetCharABCWidthsFloat(tempDC, AscW("A"), AscW("Z"), aABCFLOAT(0)) Then
For lgChr = LBound(aABCFLOAT) To UBound(aABCFLOAT)
With aABCFLOAT(lgChr)
Debug.Print Chr$(lgChr + 65) & " --> " & CStr(.abcfA + .abcfB + .abcfC)
End With
Next
End If
' Get LCase chars
ReDim aABCFLOAT(0 To 25)
'Erase aABCFLOAT()
If GetCharABCWidthsFloat(tempDC, AscW("a"), AscW("z"), aABCFLOAT(0)) Then
For lgChr = LBound(aABCFLOAT) To UBound(aABCFLOAT)
With aABCFLOAT(lgChr)
Debug.Print Chr$(lgChr + 97) & " --> " & CStr(.abcfA + .abcfB + .abcfC)
End With
Next
End If
' Get numbers
ReDim aABCFLOAT(0 To 9)
'Erase aABCFLOAT()
If GetCharABCWidthsFloat(tempDC, AscW("0"), AscW("9"), aABCFLOAT(0)) Then
For lgChr = LBound(aABCFLOAT) To UBound(aABCFLOAT)
With aABCFLOAT(lgChr)
Debug.Print Chr$(lgChr + 48) & " --> " & CStr(.abcfA + .abcfB + .abcfC)
End With
Next
End If
' Clean up (very important to avoid memory leaks!)
DeleteObject lgFont
DeleteObject tempBMP
DeleteDC tempDC
End Sub
Private Function GetCharWidths(ByVal hDC As Long, _
Optional ByRef outHeight As Long) As tABCFloat()
' You can also get the characters widths with this function
' outHeight to retrieve height
Dim TempMetrics As TEXTMETRIC
Dim aABCWidth() As tABCFloat
Dim LoopArr As Long
Call GetTextMetrics(hDC, TempMetrics)
If (TempMetrics.tmPitchAndFamily And TMPF_TRUETYPE) Then
ReDim aABCWidth(0 To (TempMetrics.tmLastChar - TempMetrics.tmFirstChar))
Call GetCharABCWidthsFloat(hDC, TempMetrics.tmFirstChar, TempMetrics.tmLastChar, aABCWidth(0))
'Else
' Call GetCharWidth32(hDC, TempMetrics.tmFirstChar, TempMetrics.tmLastChar, RetArr(TempMetrics.tmFirstChar))
End If
' Return character size array and height
GetCharWidths = aABCWidth()
outHeight = TempMetrics.tmHeight
End Function
Private Sub DivideStringInLines(ByVal hDC As Long, ByRef strSource As String)
Dim OldFont As Long
Dim OldCol As Long
Dim DrawArea As RectAPI
Dim CharABC() As tABCFloat
Dim CharWidths() As Long
Dim CharHeight As Long
Dim ThisChar As Long
Dim lgChr As Long
Dim DrawLines As Long
Dim LastBreak As Long
Dim BreakLines As Collection
Dim CurStart As Long
Dim LineWidth As Long
Dim Broken As Boolean
Const MaxLines As Long = 3 ' if more that 3 lines, stop
Const vbPixels As Long = 1
' Get strSource from Label1 control
'! 'If ((Len(Label1.Caption) = 0) Or (MaxLines < 1)) Then Exit Sub
'OldFont = SelectObject(hWndForm, StdFontToAPIFont(Label1.Font))
'OldCol = SetTextColor(hWndForm, Label1.ForeColor)
' With DrawArea
' .Left = ScaleX(Label1.Left, Label1.Parent.ScaleMode, vbPixels) + 150
'' <-- DEBUG OFFSET, REMOVE IN FINAL
' .Top = ScaleY(Label1.Top, Label1.Parent.ScaleMode, vbPixels)
' .Right = ScaleX(Label1.Width, Label1.Parent.ScaleMode, vbPixels) + .Left
' .Bottom = ScaleY(Label1.Height, Label1.Parent.ScaleMode, vbPixels) + .Top
' End With
' DT_WORDBREAK and DT_WORD_ELLIPSIS don't play well together, so we'll have to simulate multi-line manually
CharABC() = GetCharWidths(hDC, CharHeight)
ReDim CharWidths(LBound(CharABC) To UBound(CharABC))
For lgChr = LBound(CharABC) To UBound(CharABC)
With CharABC(lgChr)
CharWidths(lgChr) = .abcfA + .abcfB + .abcfC
End With
Next lgChr
Set BreakLines = New Collection
CurStart = 1
For lgChr = 1 To Len(Label1.Caption)
ThisChar = AscW(Mid(Label1.Caption, lgChr, 1))
Select Case ThisChar
Case 9, 10, 13, 32 ' Tab, Cr, Lf, Sp
LastBreak = lgChr + 1
End Select
LineWidth = LineWidth + CharWidths(ThisChar)
If (LineWidth > (DrawArea.Right - DrawArea.Left)) Then
If ((LastBreak - CurStart) > 0) Then ' Split at last word
Call BreakLines.Add(Mid$(Label1.Caption, CurStart, LastBreak - CurStart))
Else ' No break, we'll just have to split the word..
Call BreakLines.Add(Mid$(Label1.Caption, CurStart, lgChr - CurStart))
End If
' Have we got all the lines we need?
Broken = BreakLines.Count >= MaxLines
If (Broken) Then ' Yup, quit
Call BreakLines.Remove(BreakLines.Count)
BreakLines.Add (Mid$(Label1.Caption, CurStart))
Exit For
End If
If ((LastBreak - CurStart) > 0) Then CurStart = LastBreak Else CurStart = lgChr
LastBreak = CurStart
LineWidth = 0
End If
Next lgChr
For DrawLines = 1 To BreakLines.Count
Call DrawText(hWndForm, BreakLines(DrawLines), Len(BreakLines(DrawLines)), DrawArea, IIf(DrawLines = BreakLines.Count, DT_WORD_ELLIPSIS, DT_LEFT))
DrawArea.Top = DrawArea.Top + CharHeight
Next DrawLines
Call DeleteObject(SelectObject(hWndForm, OldFont))
Call SetTextColor(hWndForm, OldCol)
End Sub
'--------------------------
Private Sub UserForm_Click()
MsgBox fTextHeight(Label1, "Esto es una prueba") / TWIPSPERINCH * 2.54
End Sub
Private 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
' https://bytes.com/topic/access/answers/969375-change-font-size-fit-label-dimensions
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
Private 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
Private 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
Private 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.
'
' Structure for DrawText calc
Dim sRect As RectAPI
' 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 = GetDC(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 xlLabel, xlButtonControl ', acCommandButton 'acToggleButton, acPage (access page)
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 = GetDeviceCaps(hDC, LOGPIXELSY)
Else
lngDPI = GetDeviceCaps(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 = CreateFontIndirect(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 = CreateFontIndirect(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 = SelectObject(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 = DrawText(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 = SelectObject(hDC, OldFont)
' Delete the Font we created
DeleteObject (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 = DeleteDC(hDC)
' ' ***************************************************
'Else
' Release the handle to the Screen's DC
lngRet = ReleaseDC(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
fTextWidthOrHeight = VBA.IIf(blWH, HeightTwips, WidthTwips)
End With
' Exit normally
Exit_OK:
Exit Function
Err_Handler:
err.Raise err.Source, err.Number, err.Description
Resume Exit_OK
End Function
Private Function Nz(p1, Optional p2) As Variant
Select Case True
Case Not IsNull(p1): Nz = p1
Case IsMissing(p2): Nz = Empty
Case Else: Nz = p2
End Select
' Nz(Null) return Empty in MS Access, so the following Excel vba matches MS Access perfectly.
' to test it open vba immediate window and type ?(nz(null) = 0) & " " & (nz(null) = "")
' You will get True True
End Function
'Function Nz(fldTest As ADODB.Field, Optional vDefault As Variant) As Variant
' If IsNull(fldTest.Value) Then
' If IsMissing(vDefault) Then
' Select Case fldTest.Type
' Case adBSTR, adGUID, adChar, adWChar, adVarChar, adVarWChar
' Nz = ""
' Case Else
' Nz = 0
' End Select
' Else
' Nz = vDefault
' End If
' Else
' Nz = fldTest.Value
' End If
'End Function
Private 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
Once the userform is fired, the inmediate window will be fed with the widths of the characters. Keep on mind that any font character is defined as: The A spacing is the width to add to the current position before placing the character. The B spacing is the width of the character itself. The C spacing is the white space to the right of the character. The total advance width is determined by calculating the sum of A+B+C. The character cell is an imaginary rectangle that surrounds each character or symbol in a font. Because characters can overhang or underhang the character cell, either or both of the A and C increments can be a negative number.
Remember that the returned items are in pixels linked to the device content so, to get them in cm/mm/inches or whatever, you need to divide by GetDeviceCaps(DeskDC, LOGPIXELSY) to get them in inches, and then multiplied by the cm/mm/inch conversion factor