vb macro string width in pixel - string

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-questions/19267-width-specific-text-pixels.html
http://www.ozgrid.com/forum/showthread.php?t=94339

Answer 1

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

Answer 2

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.

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 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 5

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

Answer 6

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.

Answer 7

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 8

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

Answer 9

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 10

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