'フォント名一覧を作成するマクロ(Excel95専用)

'セル範囲を選択し、Test_GetFontNameマクロを実行してください。

Option Explicit

Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2
Private Const CB_ERR = -1
Private Const CB_GETCOUNT = &h146
Private Const CB_GETLBTEXT = &h148
Private Const CB_GETLBTEXTLEN = &h149

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

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

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpszClass As String, ByVal lpszWindow As String) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _
    ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal cchClassName As Long) As Long

Private Declare Function GetWindow Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal uCmd As Long) As Long

Private Declare Function ShowWindow Lib "user32" ( _
    ByVal hwnd As Long, _
    ByVal nShow As Long) As Long

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

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal uMsg As Long, _
    ByVal wParam As Long, _
    ByRef lParam As Any) As Long


Function GetFontName() As Variant
    Dim oBook As Workbook
    Dim oToolBar As Object
    Dim hwnd As Long
    Dim hwnd_Focus As Long
    Dim iCount As Long
    Dim iSize As Long
    Dim sFontName() As String
    Dim sBuffer As String
    Dim sName As String
    Dim dtTimeOut As Date
    Dim bFound As Boolean
    Dim iRet As Long
    Dim i As Long

    GetFontName = Empty

    On Error GoTo ErrorHandler

    For i = 1 To 255
        bFound = False
        sName = String$(i, " ")
        For Each oToolBar In Application.Toolbars
            If oToolBar.Name = sName Then
                bFound = True
                Exit For
            End If
        Next
        If Not bFound Then
            Exit For
        End If
    Next

    If bFound Then
        sName = ""
    End If

    Set oBook = Workbooks.Add(xlWorksheet)

    Set oToolBar = Toolbars.Add(Name:=sName)
    oToolBar.ToolbarButtons.Add Button:=68, Before:=1
    oToolBar.Position = xlFloating
    oToolBar.Left = Application.Width + oToolBar.Width
    oToolBar.Top = Application.Height + oToolBar.Height
    oToolBar.Visible = True

    hwnd = FindWindow("XLMAIN", Application.Caption)
    If hwnd = 0 Then
        GoTo Exit_Finally
    End If

    hwnd = FindChildWindow(hwnd, "EXCEL3")
    If hwnd = 0 Then
        GoTo Exit_Finally
    End If

    iRet = ShowWindow(hwnd, 1)
    iRet = UpdateWindow(hwnd)

    dtTimeOut = Now() + 10 / (24# * 60 * 60)
    Do
        DoEvents
        iRet = FindChildWindow(hwnd, "ComboBox")
        If iRet <> 0 Then Exit Do
    Loop While Now() <= dtTimeOut

    If iRet = 0 Then
        GoTo Exit_Finally
    End If

    hwnd = iRet

    hwnd_Focus = GetFocus()
    iRet = SetFocus(hwnd)
    If hwnd_Focus <> iRet Then
        GoTo Exit_Finally
    End If

    iCount = SendMessage(hwnd, CB_GETCOUNT, 0, ByVal 0&)
    If iCount = CB_ERR Then
        GoTo Exit_Finally
    End If

    ReDim sFontName(0 To iCount - 1)

    For i = 0 To iCount - 1
        iSize = SendMessage(hwnd, CB_GETLBTEXTLEN, i, ByVal 0&)
        If iSize > 0 Then
            sBuffer = String$(iSize, Chr$(0))
            iRet = SendMessage(hwnd, CB_GETLBTEXT, i, ByVal sBuffer)
            If iRet > 0 Then
                sFontName(i) = sBuffer
            End If
        End If
    Next

    GetFontName = sFontName

Exit_Finally:
    If hwnd_Focus <> 0 Then
        iRet = SetFocus(hwnd_Focus)
    End If
    If Not (oToolBar Is Nothing) Then
        oToolBar.Delete
    End If
    If Not (oBook Is Nothing) Then
        oBook.Close False
    End If
    Exit Function

ErrorHandler:
    If hwnd_Focus <> 0 Then
        iRet = SetFocus(hwnd_Focus)
    End If
    If Not (oToolBar Is Nothing) Then
        oToolBar.Delete
    End If
    If Not (oBook Is Nothing) Then
        oBook.Close False
    End If
    Exit Function

End Function


Private Function FindChildWindow(ByVal hwnd As Long, _
        ByVal sClassName As String) As Long
    Dim hwnd2 As Long
    Dim sBuffer As String
    Dim iRet As Long

    FindChildWindow = 0
    hwnd2 = GetWindow(hwnd, GW_CHILD)
    If hwnd2 = 0 Then
        Exit Function
    End If
    Do
        sBuffer = String$(255, Chr$(0))
        iRet = GetClassName(hwnd2, sBuffer, Len(sBuffer))
        sBuffer = Left$(sBuffer, InStr(1, sBuffer, Chr$(0), 0) - 1)
        If StrComp(sBuffer, sClassName, 0) = 0 Then
            FindChildWindow = hwnd2
            Exit Do
        End If
        hwnd2 = GetWindow(hwnd2, GW_HWNDNEXT)
    Loop Until hwnd2 = 0
End Function


Sub Test_GetFontName()
    Const myTitle = "フォント一覧の作成"
    Dim vFontName As Variant

    If Not (Application.Version Like "7.*") Then
        MsgBox "Excel95以外では実行できません。", vbExclamation, myTitle
        Exit Sub
    End If

    If TypeName(Selection) <> "Range" Then
        MsgBox "セルを選択して実行してください。", vbExclamation, myTitle
        Exit Sub
    End If

    Application.ScreenUpdating = False
    vFontName = GetFontName()
    Application.ScreenUpdating = True

    On Error GoTo ErrorHandler

    If Not IsEmpty(vFontName) Then
        Selection.Resize(UBound(vFontName) - LBound(vFontName) + 1).Select
        If Application.CountA(Selection) > 0 Then
            If MsgBox("セルを上書きしますか?", _
                vbOKCancel Or vbExclamation, myTitle) _
                <> vbOK Then Exit Sub
        End If
        Selection.Value = Application.Transpose(vFontName)
    End If

    Exit Sub

ErrorHandler:
    MsgBox Error(Err), vbExclamation, myTitle
    Exit Sub

End Sub