String vb宏字符串宽度（像素）

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

相关的：

---

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

'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

'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

---

使用参数（必须计算宽度的字符串）调用getLabelPixel函数。
如果您使用的是UserForm，一个技术性较低的解决方案是在表单中添加一个与待评估文本具有相同字体样式和大小的标签。将AutoSize设置为True，将标题设置为“空白”，将Visible设置为False，将Width设置为0，将wordWrap设置为False
此隐藏标签将成为使用以下功能对文本进行排序的测量工具：

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

用户1355（现在是Sarika.s）的答案非常好！（我本想在评论中提到这一点，但我的声誉还不够高……）
我不是在测量标签，而是单元格中的文本，我不想对字体进行假设，所以我做了一些小的修改和添加
按照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 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

'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

调用GetStringPixelWidth函数的一些示例

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

再次感谢1355/Sarika S.为我节省了大量工作

---

另外，正如一位评论者所指出的，内存泄漏并没有影响我的使用，但我确实检测到了它。如果我让他们解释/纠正这一点，我将重新发布任何更改。
为了进一步扩展和完善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

公共函数TextWidth（ByVal文本作为变量_
可选的ByVal FontName作为变量_
可选字体大小（双倍）和单倍
如果TypeName（文本）=“范围”，则
如果是missing（FontName），则设置FontName=Text
Text=Text.Value
如果结束
如果TypeName（FontName）=“范围”，则
frmTextWidth.Label1.Font=FontName.Font
ElseIf VarType（FontName）=vbString Then
如果为FontName“”，则frmTextWidth.Label1.Font.Name=FontName
如果FontSize为0，则frmTextWidth.Label1.Font.Size=FontSize
如果结束
frmTextWidth.Label1.Caption=CStr（文本）+“
TextWidth=frmTextWidth.Label1.Width
frmTextWidth.Label1.Caption=“”
TextWidth=TextWidth-frmTextWidth.Label1.Width
端函数

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

---

如果调用函数allot，可能不希望每次都设置标签的字体，因为这会使函数陷入困境。更改前，只需测试所请求的字体名称/大小是否与Label1设置的不同。
如果您在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

---

我将这段代码放在计时器上，并每秒运行一次，然后打开任务管理器并启用GDI对象列。我可以看到，在我的过程中，它会不断增加
虽然tempDC正在被删除，但我认为GetDC（0）的结果也需要被删除
（这与接受的答案有关，顺便说一句）
这种轻微的调整对我起了作用：

。。。
私有函数GetLabelSize（文本作为字符串，字体作为StdFont）作为大小
暗tempDC尽可能长
暗tempDC2与长tempDC2相同
暗淡的时间和长的时间一样长
模糊f等于长
将lf设置为LOGFONT
将文本大小设置为大小
'创建设备上下文和位图，用于存储
'临时字体对象
tempDC=CreateDC（“显示”，vbNullString，vbNullString，ByVal 0）
tempBMP=CreateCompatibleBitmap（tempDC，1，1）
'将位图分配给设备上下文
DeleteObject SelectObject（tempDC、tempBMP）
'设置LOGFONT结构并创建字体
lf.lfFaceName=font.Name&Chr$（0）
tempDC2=GetDC（0）
lf.lfHeight=-MulDiv（font.SIZE，GetDeviceCaps（tempDC2，90），72）'LOGPIXELSY
lf.lfItalic=font.Italic
lf.lf删除线=字体.删除线
lf.lfUnderline=font.Underline
如果字体为粗体，则lf.lfWeight=800，否则lf.lfWeight=400
f=CreateFontIndirective（低频）
'将字体分配给设备上下文
DeleteObject SelectObject（tempDC，f）
'测量文本，并将其返回到textSize结构中
GetTextExtentPoint32 tempDC，text，Len（text），textSize
'清理（对于避免内存泄漏非常重要！）
删除对象f
删除对象tempBMP
DeleteDC tempDC
删除DC tempDC2
“返回测量值
GetLabelSize=textSize
端函数

我发现GetLabelSize（）方法与日文字符不符
例：使用字体'ＭＳ Ｐゴシック' 11号
“a”=9像素 'あ' = 9像素
但我明白了あ' 比“a”更宽。
如果您使用Word VBA（就像我们很多人所做的那样：），则始终可以将Word.Range对象（而不是Excel.Range！）设置为所需宽度的文本，该文本必须实际存在于文档中并以相关字体呈现。然后计算范围的结束-开始-当然结果包括Word的格式/字体设置-重新调整字距，间距，