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

Question

如何使用Excel VBA宏计算字符串（以任意字体为单位）的像素数？

相关：

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

Answer 1

编写一个新的模块类并将以下代码放入其中。

'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

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

Answer 2

用户1355的答案非常好！ （我会把它放在评论中，但我的声誉还不够高......）

我不是在测量标签，而是测量单元格中的文本而我不想对字体做出假设，所以我做了一些小的修改和补充。

按照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

调用GetStringPixelWidth函数的一些示例

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

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

Answer 3

如果您使用的是UserForm，那么技术上更少的解决方案是向表单添加标签，其字体样式和大小与要评估的文本相同。将AutoSize设置为True，Caption为'blank'，Visible为False，Width为0，wordWrap为False。

使用下面的函数，此隐藏标签将成为文本排序的测量工具：

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

Answer 4

为了扩展并磨练Dustin的回答，这是我使用的代码。

与Dustin一样，我在AutoSize = True的隐藏用户表单上有一个标签。确保WordWrap = False或者你得到奇怪的结果;）

但是，每次在标签的宽度上都会添加一些额外的绒毛。要纠正它，您还需要找到空白标题的宽度并减去差异。即便这样也有问题所以在我的代码中我发现字符串加上任意字符和任意字符之间的区别。

以下代码可以放在您喜欢的任何模块中。 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

您可以提供一个范围作为字符串源，该函数将自动获取字符串及其字体。如果单元格中的字符串具有混合字体和字体大小，则可以理解此函数不起作用。你必须找到每个单独格式化字符的大小，但所涉及的代码并不太棘手。

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

Answer 5

如果您在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

Answer 6

我将此代码放在计时器上并每秒运行一次，然后打开任务管理器并启用GDI对象列。我可以看到它继续增加我的过程。

虽然正在删除tempDC，但我认为GetDC（0）的结果也必须如此？

（这与接受的答案btw有关）

这种轻微的调整对我有用：

...

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 7

我看到GetLabelSize（）方法的日语字符有误。

例如：使用字体“ MSSゴシック” 11号

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

但是我看到'あ'比'a'宽。

Answer 8

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

我一直热衷于创建不可见的草稿文档，或者在Excel中创建草稿工作簿，以用于代码中的此类工作。因此，在Word中，我将删除所有暂存文档的内容，按照“普通”样式重置所有设置，插入文本，以所需的字体/大小呈现它，将Word.Range对象设置为文本（不带最后一个段落标记） ），然后获取对象的“结束-开始”。

同样，在Excel中，我将使用草稿工作簿清除某个选项卡中某一列的所有内容，将列的宽度设置为255，确保没有自动换行，插入文本（前面带有撇号前缀）大小写！）放入单元格中，以所需的字体/大小进行渲染，自动调整列的宽度，并获取列的宽度。

Answer 9

如果您需要混合使用字体大小等，为什么不使用：

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

代替

GetTextExtentPoint32 tempDC, text, Len(text), textSize

以wRect为零矩形，返回.cx为.right和.cy为.bottom