Private Type SIZE
    cx As Long
    cy As Long
End Type

Private Const LF_FACESIZE As Long = 32
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90

Private Const FW_NORMAL = 400
Private Const FIXED_PITCH = 1

Private Const FF_MODERN = 48
Private Const SHIFTJIS_CHARSET = 128
Private Const NOANTIAliasED_QUALITY = 3

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(LF_FACESIZE) As Byte
End Type

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function GetTextExtentPoint Lib "gdi32" Alias "GetTextExtentPointA" (ByVal hdc As Long, _
                               ByVal lpszString As String, ByVal cbString As Long, ByRef lpSize As Size) As Long

Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, _
                               ByVal nDenominator As Long) As Long

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" _
                              (ByRef lpLogFont As LOGFONT) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long


'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
' 機  能：指定フォントを作成する
' 引  数：(i)hDC      … デバイスコンテキストのハンドル
'         (i)FontName … フォント名
'         (i)FontSize … フォントサイズ
' 返り値：フォントのハンドル
' 備  考：使い終わったフォントは呼び出し元できちんと破棄してね
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Private Function CreateTargetFont(ByVal hdc As Long, ByVal FontName As String, _
                                                 ByVal FontSize As Long) As Long
    Dim udtLogFont As LOGFONT   'フォント構造体
    Dim FontName2API() As Byte  'API引き渡し用フォント名バッファ
    Dim i As Long

    'フォント名をANSI化
    FontName2API = StrConv(FontName & Chr$(0), vbFromUnicode)

    'フォントを作成する
    With udtLogFont
        .lfHeight = MulDiv(FontSize, GetDeviceCaps(hdc, LOGPIXELSY), 72) * (-1)
        .lfWeight = FW_NORMAL
        For i = 0 To UBound(FontName2API)
            .lfFaceName(i) = FontName2API(i)
        Next i
        .lfPitchAndFamily = FIXED_PITCH Or FF_MODERN
        .lfQuality = NOANTIALIASED_QUALITY
        .lfCharSet = SHIFTJIS_CHARSET
    End With

    'フォントを作成する
    CreateTargetFont = CreateFontIndirect(udtLogFont)
End Function

'-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
' 機  能：指定フォントにおける文字列の幅を取得する
' 引  数：(i)FontName   … フォント名
'         (i)FontSize   … フォントサイズ
'         (i)TargetText … 対象文字列
' 返り値：文字列幅(単位：ピクセル)  エラー時：0
'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
Public Function GetFontTextWidth(ByVal FontName As String, ByVal FontSize As Long, ByVal TargetText As String) As Long
    Dim hDesktop As Long    'デスクトップのハンドル
    Dim hDesktopDC As Long  'デスクトップのデバイスコンテキストのハンドル
    Dim hNewDC As Long      '作成したデバイスコンテキストのハンドル
    Dim i As Long
    Dim hNewFont As Long    '新しいフォントのハンドル
    Dim hOldFont As Long    '古いフォントのハンドル
    Dim udtSize As SIZE     'サイズ

    'デスクトップのハンドルを取得する
    hDesktop = GetDesktopWindow

    'デスクトップのデバイスコンテキストのハンドル
    hDesktopDC = GetDC(hDesktop)
    If hDesktopDC = 0 Then GoTo ExitFunction

    '新しくデバイスコンテキストのハンドルを作成する
    hNewDC = CreateCompatibleDC(hDesktopDC)
    If hNewDC = 0 Then GoTo ExitFunction

    'フォントを作成する
    hNewFont = CreateTargetFont(hNewDC, FontName, FontSize)
    If hNewFont = 0 Then GoTo ExitFunction

    'デバイスコンテキストにフォントを割り当てる
    hOldFont = SelectObject(hNewDC, hNewFont)
    If hOldFont = 0 Then GoTo ExitFunction

    'フォントに対する文字列幅を取得する
    Call GetTextExtentPoint(hNewDC, TargetText, lstrlen(TargetText), udtSize)

    '返却
    GetFontTextWidth = udtSize.cx

ExitFunction:
    '割り当てたフォントを元に戻す
    If hOldFont <> 0 Then Call SelectObject(hNewDC, hOldFont)

    'フォントを破棄する
    If hNewFont <> 0 Then Call DeleteObject(hNewFont)

    'デバイスコンテキストを削除する
    If hNewDC <> 0 Then Call DeleteObject(hNewDC)

    'デスクトップのデバイスコンテキストのハンドルを開放する
    If hDesktopDC <> 0 Then Call ReleaseDC(hDesktop, hDesktopDC)
End Function