vb macro string width in pixel

Question

How would you calculate the number of pixels for a String (in an arbitrary font), using an Excel VBA macro?

Related:

• http://www.mrexcel.com/forum/excel

Answer 1

If you are running on a 64bit system and you get a compile error due to that, the solution will be to change the API Declares to:

    'API Declares
#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 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 SIZE) 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
#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 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 SIZE) 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
#End If

Answer 2

I see GetLabelSize() method is wrong with Japanese character.

Ex: With font 'ＭＳ Ｐゴシック' size 11

'a' = 9 pixel 'あ' = 9 pixel

But I see 'あ' is wider then 'a'.

Answer 3

If you are using a UserForm, a much less technically solution would be to add a label to the form with the same font style and size as the text to be evaluated. Set AutoSize to True, Caption to 'blank', Visible to False, Width to 0, and wordWrap to False.

This hidden label will become of measurement tool of sorts for text using the Function below:

Public Function TextLength(sString As String) As Long
    UserForm.TextMeasure.Caption = sString
    TextLength = UserForm.TextMeasure.Width
End Function

Answer 4

If you're using Word VBA (as SO MANY of us do :) ), you can always set up a Word.Range object (NOT Excel.Range!) to be the text whose width you want, which must actually exist in the document and be rendered in the relevant font. Then calculate the Range's End minus Start -- of course the results includes Word's Format/Font settings re kerning, spacing, etc., but that might be exactly what you want, the true width.

I've always been a fan of creating an invisible scratch document, or in Excel a scratch workbook, to use for stuff like this in code. So in Word I'd remove all of the scratch document's contents, reset all settings per the Normal style, insert the text, render it in the font/size desired, set a Word.Range object to the text (without the final paragraph mark) and get the object's End - Start.

Likewise in Excel I'd use a scratch workbook to clear all content from one column in some tab, set the column's width to 255, make sure of no word-wrap, insert the text (with a preceding apostrophe prefix just in case!) into a cell, render it in the desired font/size, auto-fit the column, and get the column's width.

Answer 5

If you need a mix of fonts sizes etc., why not use:

DrawText tempDC, Text, Len(Text), wRect, DT_CALCRECT ' Or DT_BOTTOM

instead of

GetTextExtentPoint32 tempDC, text, Len(text), textSize

with wRect as zero rectangle that returns .cx as .right and .cy as .bottom

Answer 6

I put this code on a timer and ran it every second, then opened up Task Manager and enabled the GDI Objects column. I could see it keep on increasing for my process.

Although tempDC is being deleted, I think the result of GetDC(0) needs to be as well?

(This is in relation to the accepted answer btw)

This slight adjustment worked for me:

...

Private Function GetLabelSize(text As String, font As StdFont) As SIZE
    Dim tempDC As Long
    Dim tempDC2 As Long
    Dim tempBMP As Long
    Dim f As Long
    Dim lf As LOGFONT
    Dim textSize As SIZE

    ' 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)

    ' Set up the LOGFONT structure and create the font
    lf.lfFaceName = font.Name & Chr$(0)
    tempDC2 = GetDC(0)
    lf.lfHeight = -MulDiv(font.SIZE, GetDeviceCaps(tempDC2, 90), 72) 'LOGPIXELSY
    lf.lfItalic = font.Italic
    lf.lfStrikeOut = font.Strikethrough
    lf.lfUnderline = font.Underline
    If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
    f = CreateFontIndirect(lf)

    ' Assign the font to the device context
    DeleteObject SelectObject(tempDC, f)

    ' Measure the text, and return it into the textSize SIZE structure
    GetTextExtentPoint32 tempDC, text, Len(text), textSize

    ' Clean up (very important to avoid memory leaks!)
    DeleteObject f
    DeleteObject tempBMP
    DeleteDC tempDC
    DeleteDC tempDC2

  ' Return the measurements
    GetLabelSize = textSize

End Function