README.md

Excel Character Width Measurement

A VBA script that measures the pixel width of all printable ASCII characters and records the results in a new Excel sheet.

Description

The VBA macro measures the width of each printable ASCII character (from space to tilde) using the GetTextExtentPoint32 Windows API function and outputs the results to an Excel sheet. This can be particularly useful for tasks that require precise layout designs in Excel, like creating forms or reports.

Requirements

• Microsoft Excel (The macro was written for the 64-bit version of Excel)
• Basic knowledge of running macros in Excel

License

This project is licensed under the MIT License - see the LICENSE.md file for details.

GetTextExtentPoint32.vba

#If VBA7 Then
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal cbString As Long, ByRef lpSize As SIZE) As Long
    Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Declare PtrSafe Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Integer, ByVal W As Integer, ByVal E As Integer, ByVal O As Integer, ByVal FW As Integer, ByVal i As Integer, ByVal U As Integer, ByVal S As Integer, ByVal C As Integer, ByVal OP As Integer, ByVal CP As Integer, ByVal Q As Integer, ByVal PAF As Integer, ByVal F As String) As LongPtr
    Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
#Else
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, ByRef lpSize As SIZE) As Long
    Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Integer, ByVal W As Integer, ByVal E As Integer, ByVal O As Integer, ByVal FW As Integer, ByVal I As Integer, ByVal U As Integer, ByVal S As Integer, ByVal C As Integer, ByVal OP As Integer, ByVal CP As Integer, ByVal Q As Integer, ByVal PAF As Integer, ByVal F As String) As Long
    Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
#End If

Public Type SIZE
    cx As Long
    cy As Long
End Type

Sub MeasureASCIIWidths()
    Dim hdc As LongPtr
    Dim lngSize As SIZE
    Dim hFont As LongPtr, hFontOld As LongPtr
    Dim i As Integer
    Dim ws As Worksheet
    Dim strChar As String
    
    ' Create a new worksheet
    Set ws = ThisWorkbook.Sheets.Add
    ws.Name = "ASCII_Widths"
    
    ' Set headers for the new sheet
    ws.Cells(1, 1).Value = "ASCII Code"
    ws.Cells(1, 2).Value = "Character"
    ws.Cells(1, 3).Value = "Width in Pixels"
    
    ' Create font similar to Calibri 11
    hFont = CreateFont(11, 0, 0, 0, FW_NORMAL, 0, 0, 0, ANSI_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_SWISS, "Calibri")
    
    ' Get the handle to the device context
    hdc = GetDC(0)
    
    ' Select the font into the device context
    hFontOld = SelectObject(hdc, hFont)
    
    ' Measure the width of each printable ASCII character
    For i = 32 To 126
        strChar = Chr(i)
        If GetTextExtentPoint32(hdc, strChar, Len(strChar), lngSize) <> 0 Then
            ws.Cells(i - 31 + 1, 1).Value = i
            ws.Cells(i - 31 + 1, 2).Value = strChar
            ws.Cells(i - 31 + 1, 3).Value = lngSize.cx
        Else
            ws.Cells(i - 31 + 1, 1).Value = i
            ws.Cells(i - 31 + 1, 2).Value = strChar
            ws.Cells(i - 31 + 1, 3).Value = "Error"
        End If
    Next i
    
    ' Restore the old font
    SelectObject hdc, hFontOld
    
    ' Release the device context
    ReleaseDC 0, hdc
    
    ' Delete the font object
    DeleteObject hFont
    
    ' Autofit columns for better visibility
    ws.Columns.AutoFit
End Sub