Function for calculating variable width font

I wish to write a underline function that can use the indicated character to underline the certain text, eg

This is the example

In this example, the function simply append a carriage return and add 13 "=".

For fixed width font like courier, we know that "This is the example" has 13 characters, we can easily use 13 "=" to underline it.

The problem is for variable width font like Times New Roman. Arial, etc, we cannot be certain that how many "=" we should use in order to underline certain text perfectly.

Is there any written function on the web that can help us to calculate this based on the font type?
(For example, If we input "Times new roman", <font size>, "This is the example", and "=" as parameter to the function, it should return approximately how many "=" should be use based on the length of the text)
(Or, If we input "Times new roman", <font size>, "This is the example"  to the function, the function should return us the length of string based on certain unit, and we use the return information to calculate our own)
(Or even there don't have any function avaialable, but there is a table of the width of font for certain font type, we write the function ourself)
(Or, something that is workable)

Who is Participating?
TimCotteeHead of Software ServicesCommented:
Hi william007,

This may look a bit complicated but does pretty much what you want it to do. If you start a new project and add a command button and picture box then paste this code. Run it and see. (You can change the text / font name / size etc if you like to something else of course). It will display the results in the picture box and tell you what the relative widths are.

Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As POINTAPI) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc 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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Const LOGPIXELSY = 90
Private Const CCHFORMNAME = 32
Private Const CCHDEVICENAME = 32
Private Const DM_BITSPERPEL = &H40000
Private Const DM_PELSWIDTH = &H80000
Private Const DM_PELSHEIGHT = &H100000
Private Const BITSPIXEL = 12
Private Const LF_FACESIZE = 32

Private Type DEVMODE
       dmDeviceName As String * CCHDEVICENAME
       dmSpecVersion As Integer
       dmDriverVersion As Integer
       dmSize As Integer
       dmDriverExtra As Integer
       dmFields As Long
       dmOrientation As Integer
       dmPaperSize As Integer
       dmPaperLength As Integer
       dmPaperWidth As Integer
       dmScale As Integer
       dmCopies As Integer
       dmDefaultSource As Integer
       dmPrintQuality As Integer
       dmColor As Integer
       dmDuplex As Integer
       dmYResolution As Integer
       dmTTOption As Integer
       dmCollate As Integer
       dmFormName As String * CCHFORMNAME
       dmUnusedPadding As Integer
       dmBitsPerPel As Long
       dmPelsWidth As Long
       dmPelsHeight As Long
       dmDisplayFlags As Long
       dmDisplayFrequency As Long
End Type

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(LF_FACESIZE) As Byte
End Type

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Sub Command1_Click()
   Dim TWidth As Long
   Dim THeight As Long
   Dim strTheText As String
   strTheText = "This is some text for a menu caption"
   GetTextDimensions strTheText, TWidth, THeight, FontSize:=20
   Dim EWidth As Long
   Dim EHeight As Long
   GetTextDimensions "=", EWidth, EHeight, FontSize:=20
   Picture1.Print strTheText
   Picture1.Print String(TWidth / EWidth, "=")
   MsgBox TWidth & vbLf & EWidth & vbLf & TWidth / EWidth
End Sub

Private Sub GetTextDimensions(ByVal TextString As String, ByRef TextWidth As Long, ByRef TextHeight As Long, Optional ByVal FontName As String = "Times New Roman", Optional ByVal FontSize As String = 12)
   Dim lngReturn As Long
   Dim lngDC As Long
   Dim DevM As DEVMODE
   Dim lfMyFont As LOGFONT
   Dim lngFont As Long
   Dim TextSize As POINTAPI
   Dim aryFontName() As Byte
   lngDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
   With lfMyFont
       SetFontFace lfMyFont, FontName
       .lfHeight = -MulDiv((FontSize), (GetDeviceCaps(lngDC, LOGPIXELSY)), 72)
   End With
   lngFont = CreateFontIndirect(lfMyFont)
   lngReturn = SelectObject(lngDC, lngFont)
   GetTextExtentPoint32 lngDC, TextString, Len(TextString), TextSize
   lngReturn = DeleteObject(lngFont)
   lngReturn = DeleteDC(lngDC)
   TextWidth = TextSize.X
   TextHeight = TextSize.Y
End Sub

Private Sub SetFontFace(ByRef MyFont As LOGFONT, ByVal DesiredName As String)
    Dim intElement As Integer
    For intElement = 0 To Len(DesiredName) - 1
        MyFont.lfFaceName(intElement) = Asc(Mid(DesiredName, intElement + 1, 1))
    MyFont.lfFaceName(Len(DesiredName)) = 0
End Sub

Tim Cottee
Farzad AkbarnejadDeveloperCommented:
Hi william007,
You can use TextWidth function. It is member function of form and it uses font of form as default font.

Hi william007

Test this, it runs from the paint(Graphics graphics).
Of course this is the soultion if you add the underline from the paint.

FontRenderContext frc;
TextLayout tl;
Graphics2D graphics2D;

//test values
String text ="someValue";
Font font =  new Font("Arial", Font.PLAIN, 12);

graphics2D = (Graphics2D)graphics;
frc = graphics2D.getFontRenderContext();
tl = new TextLayout(text, font, frc);

int textWidth = tl.getBounds().getWidth();

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Calculating width based on fonts has always been a bit of a minefield. Try looking at 

as I think this may help you, if not then you may need to write your own function that supports it's own factoring

for example...

Shared Function GenerateUnderline(byval OriginalWidth as decimal, byval textLength as integer, byval textFont as font) as Integer

' OriginalWidth as a constant width for 1 charcter (e.g. courier new 10pt font)
' textLength as the number of characters within the string to underline
' textFont is the font being used

Select Case Font.Size
    Case Between 8 and 12
        FactorX = 1.2

    Case Between 12 and 18
        FactorX = 1.5
End Select

Return ((OriginalWidth * FactorX) * textLength)

william007Author Commented:
Something like this might be on the track you're looking for.  It's definitely not the most efficient way of doing it though.

Public Function UnderlineMyText(ByVal FontName As String, ByVal FontSize As Double, ByVal TextString As String, ByVal UnderlineChar As String)
        Dim G As Graphics = Me.CreateGraphics   'Graphic objects
        Dim F As Font = New Font(FontName, FontSize)  'Font object
        Dim WidthOfText As Double = 0  'Width of the longest string (in twips)
        Dim WidthOfUnderline As Double = 0 'Width of the Underline (in twips)
        Dim strUnderline as String = Nothing

        'Get the twips width of the longest string
        WidthOfText = G.MeasureString(TextString, F).Width

        While WidthOfUnderline < WidthOfText
            strUnderline &= UnderlineChar
            WidthOfUnderline = G.MeasureString(strUnderline, F).Width
        End While
End Function
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.