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?

@Cody Gray : What I need is to set the width of an excel column based on the width of a string. When String length is used I think it may not be accurate. — skmaran.nr.iras, Feb 16 '11 at 04:50
Have you considered the simpler method of auto-fitting the entire column? Using the built-in [`AutoFit` method](http://msdn.microsoft.com/en-us/library/bb209676.aspx) seems simpler than calculating the new width yourself. — Cody Gray - on strike, Feb 16 '11 at 04:55
@Cody Gray : I have two excel columns. In first column I have to enter a string. Then take the width of that string. For the second column a width is already set. Now crop the string in the first column by comparing with the width of the second column and set the new cropped string in the second column. This is my actual need. For better comparison I think width in pixel is needed. Am I correct?. Any other suggestions have you? — skmaran.nr.iras, Feb 16 '11 at 05:10

score 19 · Accepted Answer · answered Mar 26 '12 at 06:09

Write a new module class and put the following code in it.

'Option Explicit

'API Declares

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

Private Const LOGPIXELSY As Long = 90

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 SIZE
    cx As Long
    cy As Long
End Type
Public Function getLabelPixel(label As String) As Integer

  Dim font As New StdFont
  Dim sz As SIZE
  font.Name = "Arial Narrow"
  font.SIZE = 9.5

  sz = GetLabelSize(label, font)
  getLabelPixel = sz.cx

End Function

Private Function GetLabelSize(text As String, font As StdFont) As SIZE
    Dim tempDC 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)
    lf.lfHeight = -MulDiv(font.SIZE, GetDeviceCaps(GetDC(0), 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
  ' Return the measurements
    GetLabelSize = textSize

End Function

Call the getLabelPixel function with parameter(string whose width has to be calculated).

Hello, I am fairly new to vba, I just tested this code, and it seems to work. I was wondering if you could explain the DeleteObject SelectObject(tempDC, f) line — Onekuo, Jul 12 '12 at 13:31
@Onekuo About 4 years late here, but the explanation is that SelectObject(tempDC, tempBMP) returns an object, which is then passed to DeleteObject as its only parameter. This is a shortcut instead of doing: `Dim tempObj As Long` `tempObj = SelectObject(tempDC, tempBMP)` `DeleteObject tempObj` which required an additional local variable. You only need it once, so why create the additional memory allocation and type the extra code? — 4AM, May 31 '16 at 19:20
There appears still to be a memory leak in here. I'm checking about 19,000 strings and my system slows and complains of low memory. Thanks anyway, I'll try to find the leak. — pdr0663, Oct 18 '22 at 04:58

TravelinGuy · Answer 2 · 2021-04-28T18:00:52.453

User 1355's (now Sarika.S) answer is excellent! (I would have put that in the comments, but my reputation is not high enough... yet.)

I'm not measuring labels, but text within a cell and I didn't want to make assumptions about the font, so I made some minor modifications and additions.

As instructed by 1355, Write a new code module and put the following code in it.

'Option Explicit

'API Declares

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 FNTSIZE) 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 Const LOGPIXELSY As Long = 90

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 FNTSIZE
    cx As Long
    cy As Long
End Type


Public Function GetLabelPixelWidth(label As String) As Integer

    Dim font As New StdFont
    Dim sz As FNTSIZE
    font.Name = "Arial Narrow"
    font.Size = 9.5
    
    sz = GetLabelSize(label, font)
    getLabelPixelWidth = sz.cx

End Function


Public Function GetStringPixelHeight(text As String, fontName As String, fontSize As Single, Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer

    Dim font As New StdFont
    Dim sz As FNTSIZE
    font.Name = fontName
    font.Size = fontSize
    font.Bold = isBold
    font.Italic = isItalics
    
    sz = GetLabelSize(text, font)
    GetStringPixelHeight = sz.cy

End Function


Public Function GetStringPixelWidth(text As String, fontName As String, fontSize As Single, Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer

    Dim font As New StdFont
    Dim sz As FNTSIZE
    font.Name = fontName
    font.Size = fontSize
    font.Bold = isBold
    font.Italic = isItalics

    sz = GetLabelSize(text, font)
    GetStringPixelWidth = sz.cx

End Function


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

    ' 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)
    lf.lfHeight = -MulDiv(font.Size, GetDeviceCaps(GetDC(0), 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
    ' Return the measurements
    GetLabelSize = textSize

End Function

Some examples of calling the GetStringPixelWidth function

MsgBox (GetStringPixelWidth("Test String", "Calibri", 10))
MsgBox (GetStringPixelWidth(" ", "Calibri", 10, True, False))

Thanks again to 1355/Sarika S. for saving me tons of work!

Also, there is a memory leak as noted by one commenter, which didn't affect my uses but I did detect it. I will re-post with any changes if I make them to account for/correct that.

Ran into a User-defined type error when I tried this on `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`. Just had to change `SIZE` to `FNTSIZE`. Thought this might help someone down the road. Thanks for the code. — Hubvill, Sep 14 '15 at 19:53
For other who will try it. I wasn't able to make it works in a class module, but it works fine + There is a memory leaks with `GetDC(0)` not being freed, it make the function works slower and slower. In order to fix it, read the [answer of Rawden Hoof](https://stackoverflow.com/a/49533316/15748490) + `GetStringPixelHeight` try to return throught `GetStringPixelWidth` that obviously is a copy/paste error — SomeDude, Apr 27 '21 at 21:22
Thanks to SomeDude for the Height/Width catch and memory leak solution suggestion. I've corrected the first one, and will research the second. — TravelinGuy, Apr 28 '21 at 18:01
@TravelinGuy, for the memory leak, it's just two lines after the comment `' Set up the LOGFONT structure and create the font` the `GetDC(0)` create a DC never freed (is it english?). As suggested by Rawden Hoof below, you need to write `Set TempDC2 = GetDC(0)` on the previous line (after declaring it properly) and then `lf.lfHeight = -MulDiv(font.Size, GetDeviceCaps(TempDC2, 90), 72)` and finally at the end `DeleteDC tempDC2`. As I almost only program in VBA, I can't explain why it's needded, but I also found the memory leak while benching my code and needed this in order to fix it. — SomeDude, May 04 '21 at 22:41

score 8 · Answer 3 · answered Nov 22 '14 at 22:19

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.

enter image description here

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

score 4 · Answer 4 · answered Jun 27 '16 at 12:53

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

Rawden Hoff · Answer 5 · 2018-03-28T13:35:38.170

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

AHeyne · Answer 6 · 2021-12-27T09:12:17.883

This is my adapted code supporting 32- and 64-bit and unicode strings by usage of '*W'-api's:

Minimum supported Microsoft Access version is 2010 (VBA 7).

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 FNTSIZE
    cx As Long
    cy As Long
End Type

Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCW" (ByVal lpDriverName As LongPtr, ByVal lpDeviceName As LongPtr, ByVal lpOutput As LongPtr, lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectW" (ByRef lpLogFont As LOGFONT) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32W" (ByVal hdc As LongPtr, ByVal lpsz As LongPtr, ByVal cbString As Long, lpSize As FNTSIZE) 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 LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long

Public Function GetLabelPixel(ByVal xLabel As String) As Integer
    Dim xFont As New StdFont
    Dim sz As FNTSIZE
    xFont.Name = "Segoe UI"
    xFont.Size = 10

    sz = GetLabelSize(xLabel, xFont)
    GetLabelPixel = sz.cx
End Function

Private Function GetLabelSize(ByVal xText As String, ByVal xFont As StdFont) As FNTSIZE
    ' Create a device context and a bitmap that can be used to store a
    ' temporary font object
    Dim tempDC As LongPtr
    tempDC = CreateDC(StrPtr("DISPLAY"), StrPtr(vbNullString), StrPtr(vbNullString), ByVal 0)

    Dim tempBMP As LongPtr
    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
    Dim lf As LOGFONT
    lf.lfFaceName = xFont.Name & Chr$(0)

    Dim tempDC2 As LongPtr
    tempDC2 = GetDC(0)

    lf.lfHeight = -MulDiv(xFont.Size, GetDeviceCaps(tempDC2, 90), 72) 'LOGPIXELSY
    lf.lfItalic = xFont.Italic
    lf.lfStrikeOut = xFont.Strikethrough
    lf.lfUnderline = xFont.Underline
    If xFont.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400

    Dim f As LongPtr
    f = CreateFontIndirect(lf)

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

    ' Measure the text, and return it into the textSize FNTSIZE structure
    Dim textSize As FNTSIZE
    GetTextExtentPoint32 tempDC, StrPtr(xText), Len(xText), textSize

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

  ' Return the measurements
    GetLabelSize = textSize
End Function

Most improved version, incorporating the proposed memory leak fix. Works with VBA 7.1.1127 in Access 2019 (16.0.10394.20022) x32 on Win10 x64 as per what [`GetTextExtentPoint32W()`](https://learn.microsoft.com/en-us/windows/win32/api/wingdi/nf-wingdi-gettextextentpoint32w) is capable of. — AmigoJack, Mar 16 '23 at 17:17

score 2 · Answer 7 · answered Jul 09 '15 at 16:30

To expand on and hone Dustin's answer, here is the code that I use.

Like Dustin, I have a label on a hidden user form with AutoSize = True. Make sure WordWrap = False or else you get bizarre results;)

However, there is a bit of extra fluff added onto the label's width each time. To correct for it, you need to also find the width of an blank caption and subtract the difference. Even that is problematic sometimes so in my code I find the difference between the string plus an arbitrary character and the arbitrary character by itself.

The following code can go in any module you like. frmTextWidth is the name of the custom form and Label1 is the label that will measure the width of text.

Public Function TextWidth(ByVal Text As Variant, _
                 Optional ByVal FontName As Variant, _
                 Optional FontSize As Double) As Single

  If TypeName(Text) = "Range" Then
    If IsMissing(FontName) Then Set FontName = Text
    Text = Text.Value
  End If

  If TypeName(FontName) = "Range" Then
    frmTextWidth.Label1.Font = FontName.Font
  ElseIf VarType(FontName) = vbString Then
    If FontName <> "" Then frmTextWidth.Label1.Font.Name = FontName
    If FontSize <> 0 Then frmTextWidth.Label1.Font.Size = FontSize
  End If      

  frmTextWidth.Label1.Caption = CStr(Text) + "."
  TextWidth = frmTextWidth.Label1.Width

  frmTextWidth.Label1.Caption = "."
  TextWidth = TextWidth - frmTextWidth.Label1.Width

End Function

You can supply a range as the string source and the function will automatically pick up the string and its font. If you have a string in a cell that has mixed fonts and font sizes, you can understand that this function won't work. You would have to find the size of each individual formated character but the code involved is not too tricky.

If you call the function allot, you may not want to set the font of the label every time because it will bog down the function. Simply test to see if the requested font name/size is different than what Label1 is set to before changing it.

score 1 · Answer 8 · answered Nov 12 '19 at 08:22

1

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

answered Nov 12 '19 at 08:22

Pham Ngoc Nam

101
1

See my sample supporting unicode strings: https://stackoverflow.com/a/70481996/7658533 – AHeyne Dec 25 '21 at 18:33

score 0 · Answer 9 · answered Dec 12 '19 at 14:52

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.

score 0 · Answer 10 · edited Feb 10 '20 at 01:27

0

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

edited Feb 10 '20 at 01:27

Paul Roub

36,322
27
84
93

answered Feb 10 '20 at 00:41

Harry S

481
6
5

vb macro string width in pixel

10 Answers10

Linked