For Information Only
I searched fruitlessly for help on working out how much text would fill a Caption on a Radio Button (or more precisely, would the intended text fit when populating the Radio Button via VBA).
With the help of others Mr. Excel members, I offer the following VBA solution, which may be a useful starting point for anyone with a similar problem.
To test it, create a Worksheet called “work”.
Then, create a Userform (Userform1), and on that Userform create a Frame (Frame1). In the Frame, create an option button (OptionButton1). Adjust the sizes if you wish, depending on your likely requirements.
Create three VBA modules. I happened to name them “modAPI”, “modAAATest”, and “modSample”, so I’ll use those names in the instructions.
modAPI is the clever bit (thanks RoryA) which allows us to validate the Font name, thereby avoiding a Microsoft "facility" which allows you to accidentally add any old font name using VBA. It's also a LOT faster than scanning a Font list in normal VBA.
modTest populates the test Userfom with text, or truncates it if it is too large..
modSample tests the routine which calculates the text size, and shows the effect of different font settings. It has comments on which code is necessary, and which is diagnostic.
These modules are not intended to offer a finished solution, just hopefully a good clue to facilitate your particular project - for instance modTest could easily be amended to return a Boolean flag to indicate if the proposed text would actually fit.
To see what happens, run modSample to examine text sizes, or modTest to truncate the Caption text to the size of a non Autosize Radio Button.
Enjoy!...
Put the following code in modAPI :-
Put the following code in modSample:-
Put the following code in modAAATest :-
I searched fruitlessly for help on working out how much text would fill a Caption on a Radio Button (or more precisely, would the intended text fit when populating the Radio Button via VBA).
With the help of others Mr. Excel members, I offer the following VBA solution, which may be a useful starting point for anyone with a similar problem.
To test it, create a Worksheet called “work”.
Then, create a Userform (Userform1), and on that Userform create a Frame (Frame1). In the Frame, create an option button (OptionButton1). Adjust the sizes if you wish, depending on your likely requirements.
Create three VBA modules. I happened to name them “modAPI”, “modAAATest”, and “modSample”, so I’ll use those names in the instructions.
modAPI is the clever bit (thanks RoryA) which allows us to validate the Font name, thereby avoiding a Microsoft "facility" which allows you to accidentally add any old font name using VBA. It's also a LOT faster than scanning a Font list in normal VBA.
modTest populates the test Userfom with text, or truncates it if it is too large..
modSample tests the routine which calculates the text size, and shows the effect of different font settings. It has comments on which code is necessary, and which is diagnostic.
These modules are not intended to offer a finished solution, just hopefully a good clue to facilitate your particular project - for instance modTest could easily be amended to return a Boolean flag to indicate if the proposed text would actually fit.
To see what happens, run modSample to examine text sizes, or modTest to truncate the Caption text to the size of a non Autosize Radio Button.
Enjoy!...
Put the following code in modAPI :-
Code:
Option Explicit
Private Const DEFAULT_CHARSET = 1
Public Const LF_FACESIZE = 32
Public 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(LF_FACESIZE) As Byte
End Type 'LOGFONT
Public Type NEWTEXTMETRIC
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
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type 'NEWTEXTMETRIC
Dim aFonts() As String
Dim lCounter As Long
Private Declare Function _
EnumFontFamiliesEx _
Lib "gdi32" _
Alias "EnumFontFamiliesExA" _
(ByVal hdc As Long, _
lpLogFont As LOGFONT, _
ByVal lpEnumFontProc As Long, _
ByVal LParam As Long, _
ByVal dw As Long) As Long
Private Declare Function _
GetDC _
Lib "user32" _
(ByVal hwnd As Long) As Long
Public Function EnumFontFamProc(lpNLF As LOGFONT, _
lpNTM As NEWTEXTMETRIC, _
ByVal FontType As Long, _
LParam As Long) As Long
lCounter = lCounter + 1
ReDim Preserve aFonts(lCounter)
aFonts(lCounter) = StrConv(lpNLF.lfFaceName, _
vbUnicode)
EnumFontFamProc = 1
End Function 'EnumFontFamProc
Public Function funAPI_Font_Exists(sFont As String) As Boolean
Dim LF As LOGFONT
LF.lfCharSet = DEFAULT_CHARSET
'enumerates the fonts
EnumFontFamiliesEx GetDC(Application.hwnd), _
LF, _
AddressOf EnumFontFamProc, _
ByVal 0&, _
0
funAPI_Font_Exists = Not IsError(Application.Match(sFont, _
aFonts, _
0))
End Function 'funAPI_Font_ExistsPut the following code in modSample:-
Code:
Option Explicit
Dim strMsg As String
Public Sub TestHarness()
'*
'** Code to test the routine which determines the
'** Point size of a text string.
'*
Dim intFontSize As Integer
Dim sngRes As Single
Dim strText As String
Dim strFont As String
Dim booBold As Boolean
Dim booItalic As Boolean
'*
'** As we're placing text in a cell and
'** resizing that cell's column, we speed
'** things up (marginally) bu turning off
'** screen updating.
'*
Application.ScreenUpdating = False
strText = "A string of text big enough to exaggerate differences!!!" & vbCrLf
'*
'** strMsg is used to hold the results of
'** all of the tests (which is why
'** it is defined outside of the Sub).
'** All references to it can be removed
'** in the eventual Production application.
'*
strMsg = strText & vbCrLf
'*
'** The Function funGetPointSize returns
'** the point size of the text.
'*
sngRes = funGetpointSize(strText)
strMsg = strMsg & " = " & sngRes & vbCrLf
'*
'** If you want to see what's happening,
'** comment out the Application.ScreenUpdating
'** lines, and uncomment the MsgBox lines
'** like the next one.
'*
' Call MsgBox("Width in points is " & sngRes)
sngRes = funGetpointSize(strText, 22)
strMsg = strMsg & " = " & sngRes & vbCrLf
' Call MsgBox("Width in points is " & sngRes)
sngRes = funGetpointSize(strText, 16)
strMsg = strMsg & " = " & sngRes & vbCrLf
' Call MsgBox("Width in points is " & sngRes)
sngRes = funGetpointSize(strText, 16, , True)
strMsg = strMsg & " = " & sngRes & vbCrLf
' Call MsgBox("Width in points is " & sngRes)
sngRes = funGetpointSize(strText, 16, "Times New Roman")
strMsg = strMsg & " = " & sngRes & vbCrLf
' Call MsgBox("Width in points is " & sngRes)
sngRes = funGetpointSize(strText, 16, "Times New Roman", True)
strMsg = strMsg & " = " & sngRes & vbCrLf
' Call MsgBox("Width in points is " & sngRes)
sngRes = funGetpointSize(strText, 16, "Times New Roman", True, True)
strMsg = strMsg & " = " & sngRes & vbCrLf
' Call MsgBox("Width in points is " & sngRes)
sngRes = funGetpointSize(strText, , "XXXGherkinJuiceXXX")
strMsg = strMsg & " = " & sngRes & vbCrLf
' Call MsgBox("Width in points is " & sngRes)
'*
'** Now show the results for every test.
'*
Call MsgBox(strMsg)
Application.ScreenUpdating = True
End Sub 'TestWidth3
Public Function funGetpointSize(strText As String, _
Optional intSize As Integer = 8, _
Optional strFont As String = "Tahoma", _
Optional booBold As Boolean = False, _
Optional booItalic As Boolean = False) As Single
'*******************************************
'** This Function depends on there *
'** being a Worksheet called "Work". *
'** It places the text in Cell A1 of *
'** that Worksheet, then applies *
'** formatting to that Cell, then recovers *
'** the Cell's width, thus obtaining *
'** the point size of the text. *
'*******************************************
'*
'** REMOVE THE FOLLOWING LINES OF
'** DIAGNOSTIC CODE WHEN LIVE.
'*
strMsg = strMsg & _
strFont & ", " & _
intSize & ", " & _
booBold & ", " & _
booItalic
'*
'** REAL CODE STARTS HERE
'*
If strFont <> "Tahoma" Then
If funAPI_Font_Exists(strFont) = False Then
strFont = "Tahoma"
End If
End If
With Worksheets("work").Range("a1")
.Value = strText
.WrapText = False
.Font.Name = strFont
.Font.Size = intSize
.Font.Italic = booItalic
.Font.Bold = booBold
.EntireColumn.AutoFit
funGetpointSize = .Width
End With
End Function 'funGetPointSize
Code:
Option Explicit
Public Sub Test()
Dim lngDrop As Long
Dim lngRBWidth As Long
Dim lngTextChars As Long
Dim strText As String
Dim strTextToFit As String
Dim sngButtonWidth As Single
Dim sng1CharLen As Single
Dim sngOverflow As Single
Dim sngTextInPoints As Single
'*
'** Set sample text.
'*
strText = "This text is an example of something whose length is exactly 75 characters."
'*
'** Count characters in text.
'*
lngTextChars = Len(strText)
'*
'** Get point size of text.
'*
sngTextInPoints = funGetpointSize(strText)
'*
'** Find point size of a single character.
'*
sng1CharLen = sngTextInPoints / lngTextChars
'*
'** By inspection, the radio button bit takes
'** up about 15 points.
'*
lngRBWidth = 15
With UserForm1
'*
'** Reduce the control's width value to get
'** the available Caption width.
'*
sngButtonWidth = .OptionButton1.Width - lngRBWidth
'*
'** Is there too much text to fit?
'*
sngOverflow = sngTextInPoints - sngButtonWidth
If sngOverflow > 0 Then 'Yes!
'*
'** Find out how many characters to drop
'** (rounded up).
'*
lngDrop = Application.RoundUp(sngOverflow / sng1CharLen, 0)
'*
'** Modify the text to use as the Caption.
'*
strTextToFit = Left(strText, lngTextChars - lngDrop)
Else 'No!
strTextToFit = strText
End If
.OptionButton1.Caption = strTextToFit
.Show
End With
End Sub 'Test
