Measure Character Width (regardless of controls and forms) 1

[codecref]

is it possible to do that only with api calls without doing printer or something ? because I want to use this function vba and getting form handle.
I need to specify text font,italic,bold,size and measure the word or character exact width in pixel format to do my customized wrapping text.

I know it has asked alot in forum and I did a search through all but none could help me.

thanks in advance.

 

[strongm]

You will always need a device context to 'measure' the text on (different devices have different resolutions, so the pixel width and height of a font of a given point size will be different for each device).

If that is the case (and assuming that you are not mixing font styles in a block of text) then GetTextExtentPoint32 is an API call you should have a look at.

If you are mixing font styles then the easiest way I know is to leverage a hidden richtextbox (or, if you really want a pure API solution and are slightly masochistic you can always create your own rich edit control through CreateWindowEx) and the EM_FORMATRANGE message.

Both of these solutions have been illustrated in this forum

 

[codecref]

thanks for your reply, I found a functino somewhere on net. hope it helps someone else after me,

thanks to the author.

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
Public Type SIZE
    cx As Long
    cy As Long
End Type
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
' ===================================

'
' GetTextSize
' -> Measures the size in pixels of a string, given a particular font. This uses
'    the GetTextExtentPoint32 API to measure the string. The API is defined as
'    follows:
'
'      GetTextExtendPoint(ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE)
'        hdc:       The device context which is attached to the font to be used
'        lpsz:      The string to measure, based on the font contained in the hdc specified
'        cbString:  The length of the string which was passed in 'lpsz'
'        lpSize:    The SIZE structure which the measurements will be returned to
'
'
Public Function GetTextSize(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), LOGPIXELSY), 72)
    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
    GetTextSize = textSize
End Function

 

[strongm]

We can do exactly the same thing with a little less code by letting VB do some of the hard work for us:

[blue]
Option Explicit

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long

Private Type SIZE
    cx As Long
    cy As Long
End Type

Public Function vbGetTextWidth(ByVal strSource As String, Font As StdFont) As Long
    Dim myFont As IFont ' We want the IFont interface
    Dim hFont As Long
    Dim mySize As SIZE
    Dim hdc As Long
    
    Set myFont = Font ' switch interface
    myFont.SIZE = Font.SIZE * 1000 ' increases accuracy since resultant mysize only hold longs
    
    hdc = CreateCompatibleDC(0) ' compatible with screen display
    hFont = SelectObject(hdc, myFont.hFont)
    GetTextExtentPoint32 hdc, strSource, Len(strSource), mySize
    
    'Clean up as much as we need to
    SelectObject hdc, hFont
    DeleteDC hdc
    
    vbGetTextWidth = mySize.cx / 1000 ' bring back to normal
End Function[/blue]