vba 以像素为单位的 vb 宏字符串宽度

vb macro string width in pixel

提问by Sarika.S

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

您将如何使用 Excel VBA 宏计算字符串（任意字体）的像素数？

Related:

有关的：

• http://www.mrexcel.com/forum/excel-questions/19267-width-specific-text-pixels.html
• http://www.ozgrid.com/forum/showthread.php?t=94339

• http://www.mrexcel.com/forum/excel-questions/19267-width-specific-text-pixels.html
• http://www.ozgrid.com/forum/showthread.php?t=94339

回答by Sarika.S

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

使用参数（必须计算其宽度的字符串）调用 getLabelPixel 函数。

回答by TravelinGuy

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

用户1355的回答太好了！（我会把它放在评论中，但我的声誉还不够高......还没有。）

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 module class and put the following code in it.

按照1355的指示，写一个新的模块类，在里面放入如下代码。

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

调用 GetStringPixelWidth 函数的一些示例

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

Thanks again to 1355 for saving me tons of work!

再次感谢 1355 为我节省了大量的工作！

回答by Dustin

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.

如果您使用的是用户窗体，则技术上要少得多的解决方案是向窗体添加与要评估的文本具有相同字体样式和大小的标签。将 AutoSize 设置为 True，将 Caption 设置为 'blank'，将 Visible 设置为 False，将 Width 设置为 0，并将 wordWrap 设置为 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

回答by Shawn Pauliszyn

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 = Falseor else you get bizarre results;)

像达斯汀一样，我在隐藏的用户表单上有一个标签，带有AutoSize = True. 确保WordWrap = False否则你会得到奇怪的结果;)

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. frmTextWidthis the name of the custom form and Label1is the label that will measure the width of text.

以下代码可以放在您喜欢的任何模块中。 frmTextWidth是自定义表单的名称，也是Label1用于测量文本宽度的标签。

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 Label1is set to before changing it.

如果你调用allot函数，你可能不想每次都设置标签的字体，因为它会卡住函数。只需测试以查看请求的字体名称/大小是否与Label1更改之前设置的不同。

回答by PeterPan

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:

如果您在 64 位系统上运行并因此出现编译错误，解决方案是将 API 声明更改为：

    '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

回答by Rawden Hoff

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.

我把这段代码放在一个计时器上并每秒运行一次，然后打开任务管理器并启用 GDI 对象列。我可以看到它在我的过程中不断增加。

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

虽然 tempDC 被删除了，我觉得 GetDC(0) 的结果也需要这样吗？

(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

回答by Pham Ngoc Nam

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

我看到 GetLabelSize() 方法对日语字符有误。

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

例如：使用字体“ＭＳ Ｐゴシック”大小 11

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

'a' = 9 像素 'あ' = 9 像素

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

但我看到“あ”比“a”更宽。

回答by J. Andrew Smith

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.

如果您使用 Word VBA（就像我们中的许多人一样 :) ），您总是可以将 Word.Range 对象（不是 Excel.Range！）设置为您想要宽度的文本，它必须实际存在于文档并以相关字体呈现。然后计算范围的结束减去开始——当然结果包括 Word 的格式/字体设置重新调整、间距等，但这可能正是您想要的，真正的宽度。

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.

我一直很喜欢创建一个不可见的临时文档，或者在 Excel 中创建一个临时工作簿，以在代码中使用这样的东西。因此，在 Word 中，我会删除所有草稿文档的内容，根据 Normal 样式重置所有设置，插入文本，以所需的字体/大小呈现它，将 Word.Range 对象设置为文本（没有最后的段落标记） ) 并获取对象的结束 - 开始。

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.

同样在 Excel 中，我会使用临时工作簿来清除某个选项卡中一列的所有内容，将列的宽度设置为 255，确保没有自动换行，插入文本（在前面加上撇号前缀以防万一！）放入一个单元格中，以所需的字体/大小呈现它，自动调整列，并获取列的宽度。

回答by Harry S

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 wRectas zero rectangle that returns .cxas .rightand .cyas .bottom

与wRect作为零矩形回报 .cx作为.right与.cy作为.bottom