获取特定字体配置中文本的实际宽度？

Posted 2023-03-31

【中文标题】获取特定字体配置中文本的实际宽度？

【英文标题】：Get actual width of text in a particular font configuration?

【发布时间】：2016-12-07 05:37:04

【问题描述】：

我正在打印条形码，作为该过程的一部分，我有一个 Chart 对象，上面有一个文本框。

我使用从这里获得的 clsBarcode 类在其上渲染条形码 Generating Code 128 Barcodes using Excel VBA

现在我的问题是我无法分辨条形码的宽度。

我在该图表对象上生成条形码，然后将图表导出为 jpeg 文件。我一直在为图表对象使用固定大小，但现在我正在尝试打印不同大小的条形码，并且必须调整图表对象以匹配条形码大小，否则它会被剪裁。

我在这里找到了一个 strWidth 函数 http://www.ozgrid.com/forum/showthread.php?t=94339

不幸的是，它使用查找表来查找常用字体。表中没有code128.fft的条目。

所以我有点卡在这里。如果我只是将图表的大小调整为任何条码的最大可能大小，那么我的条码图像中就会出现很多浪费的空白。由于我将这些条形码打印在 2"x4" 贴纸上，您可以猜到空间非常宝贵。

我认为最好的方法是使用 code128 字符的值填充查找表。条码类表明 chr 32 到 126 和 200 到 211 正在使用中。

如何计算这些字符的 mafChrWid(i) 值？

谢谢！

【参考方案1】：

对于此功能，您需要命名一个单元格 BARCODE 并设置它的字体 code128.fft。

Function getBarCodeWidth(strBarcode As String) As Double

    With Range("BARCODE")
        .Formula = "=Code128_Str(" & strBarcode & ")"
        .Worksheet.Columns(.Column).AutoFit
        getBarCodeWidth = .Width
    End With

End Function

【参考方案2】：

我不记得我在哪里获得了确定字体大小的原始代码。我将它修改为一个易于使用的函数，可用于自动调整文本框的大小以适应其内容。将下面的代码放到它自己的模块中，然后您可以 getLabelPixel(theControlYouWantToSizeToItsContents) 作为文本框的宽度。

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(textBox As Control) As Integer
    Dim font As New StdFont
    Dim sz As SIZE
    font.Name = textBox.FontName
    font.SIZE = textBox.FontSize
    font.Weight = textBox.FontWeight

    sz = GetLabelSize(textBox.Value, font)
    getLabelPixel = sz.cx * 15 + 50   'Multiply this by 15 to get size in twips and +50 to account for padding for access form. .cx is width for font height us .cy
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
    lf.lfWeight = font.Weight
    '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