vb ancho de cadena de macros en píxel

Question

¿Cómo calcularía el número de píxeles de una cadena (en una fuente arbitraria), utilizando una macro de Excel VBA?

relacionadas:

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

Answer 1

Escribir un nuevo módulo de clase y poner el siguiente código en él.

'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 

Llame a la función getLabelPixel con el parámetro (cadena cuyo ancho debe calcularse).

Answer 2

Si está utilizando un UserForm, una solución mucho menos técnica sería agregar una etiqueta al formulario con el mismo estilo de fuente y tamaño que el texto que se evaluará. Establezca AutoSize en True, Caption en 'blank', Visible en False, Width en 0 y wordWrap en False.

Esta etiqueta oculta será de herramienta de medición de las clases para el texto usando la función a continuación: Respuesta

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

Answer 3

usuario de 1355 es excelente! (Lo habría puesto en los comentarios, pero mi reputación no es lo suficientemente alta ... todavía.)

No estoy midiendo etiquetas, sino texto dentro de una celda y no quería hacer suposiciones sobre la fuente, así que hice algunas modificaciones menores y adiciones.

Según las instrucciones de 1355, escriba una nueva clase de módulo y coloque el siguiente código en ella.

'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 

Algunos ejemplos de llamar a la función GetStringPixelWidth

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

Gracias de nuevo a 1355 por salvarme toneladas de trabajo!

Answer 4

Para ampliar y perfeccionar la respuesta de Dustin, aquí está el código que uso.

Al igual que Dustin, tengo una etiqueta en un formulario de usuario oculto con AutoSize = True. Asegúrese de WordWrap = False o si no obtiene resultados extraños;)

Sin embargo, cada vez se agrega un poco de pelusa extra en el ancho de la etiqueta. Para corregirlo, también necesita encontrar el ancho de un título en blanco y restar la diferencia. Incluso eso es problemático a veces, así que en mi código encuentro la diferencia entre la cadena más un carácter arbitrario y el carácter arbitrario en sí mismo.

El siguiente código puede ir en cualquier módulo que desee. frmTextWidth es el nombre del formulario personalizado y Label1 es la etiqueta que medirá el ancho del texto.

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 

Puede suministrar un rango como fuente de cadena y la función recogerá automáticamente la cadena y su fuente. Si tiene una cadena en una celda que tiene fuentes y tamaños de fuente mezclados, puede comprender que esta función no funcionará.Tendría que encontrar el tamaño de cada carácter formateado individual, pero el código involucrado no es demasiado complicado.

Si llama a la función asignar, es posible que no desee configurar la fuente de la etiqueta cada vez porque se empantanará la función. Simplemente pruebe para ver si el nombre/tamaño de la fuente solicitada es diferente de lo que Label1 está configurado antes de cambiarlo.

Answer 5

Si está ejecutando en un sistema de 64 bits y se obtiene un error de compilación debido a eso, la solución será cambiar la API Declarara:

'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