'拡張メタファイルからビットマップを抽出するマクロ（Excel2000）

'★★★ 注意 ★★★
'関数ポインタを使っているため、マクロを中断すると強制終了する危険性があります！
'ステップ実行はしないでください。デバッグは慎重に行ってください。

'標準モジュールを挿入し（Visual Basic Editor [挿入]-[標準モジュール]）
'以下のコードをコピー貼り付けしてください。
'シート上の図を選択して [ツール]-[マクロ]-[マクロ]で
'SaveBitmapFromClipboardMetafile マクロを実行してください。
'ビットマップは EMFR001.BMP のようなファイル名で保存されます。

Option Explicit

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type HANDLETABLE
    objectHandle(1) As Long
End Type

Private Type ENHMETARECORD
    iType As Long
    nSize As Long
    dParm(1) As Long
End Type

Private Const CF_ENHMETAFILE As Long = 14

Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hmf As Long, ByVal lpFileName As Long) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hemf As Long) As Long
Private Declare Function EnumEnhMetaFile Lib "gdi32" (ByVal hdc As Long, ByVal hemf As Long, ByVal lpEnhMetaFunc As Long, lpData As Any, lpRect As RECT) As Long

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    
Private Const PREFIX As String = "EMFR"

Public Function EnumEnhMetaFileProc(ByVal hdc As Long, ByRef lpHTable As HANDLETABLE, _
    ByRef lpEMFR As ENHMETARECORD, ByVal nObj As Long, lpData As Long) As Long
    Dim a() As Byte
    Dim p As Long
    Dim offBmiSrc As Long
    Dim offBitsSrc As Long
    Dim nDIBSize As Long
    Dim fno As Long
    Dim n As Long
    Dim Ret As Long

    On Error Resume Next

    If lpEMFR.iType = 81 And lpEMFR.nSize > 4 * 12 Then
        p = VarPtr(lpEMFR)
        MoveMemory offBmiSrc, ByVal CLng(p + 8 + 4 * 10), 4
        MoveMemory offBitsSrc, ByVal CLng(p + 8 + 4 * 12), 4

        nDIBSize = lpEMFR.nSize - offBmiSrc

        If offBmiSrc >= 8 + 4 * 18 And offBitsSrc >= offBmiSrc + &H28 And nDIBSize > offBitsSrc Then
            ReDim a(0 To nDIBSize + 14 - 1)
            MoveMemory a(14), ByVal CLng(p + offBmiSrc), nDIBSize
            a(0) = &H42
            a(1) = &H4D
            n = 14 + nDIBSize
            MoveMemory a(2), n, 4
            n = 14 + (offBitsSrc - offBmiSrc)
            MoveMemory a(10), n, 4
            lpData = lpData + 1
            fno = FreeFile()
            Open PREFIX & Format(lpData, "000") & ".BMP" For Binary As #fno
            Put #fno, , a
            Close #fno
        End If
    End If
    EnumEnhMetaFileProc = 1
End Function

Private Function GetClipboardEnhMetaFile() As Long
    Dim hmf As Long
    Dim hmf2 As Long
    Dim Ret As Long
    On Error GoTo ErrorHandler
    GetClipboardEnhMetaFile = 0
    If IsClipboardFormatAvailable(CF_ENHMETAFILE) = 0 Then Exit Function
    If OpenClipboard(0) = 0 Then Exit Function
    hmf = GetClipboardData(CF_ENHMETAFILE)
    If hmf = 0 Then
        Ret = CloseClipboard()
        Exit Function
    End If
    hmf2 = CopyEnhMetaFile(hmf, 0&)
     If hmf2 = 0 Then
        Ret = CloseClipboard()
        Exit Function
    End If
    Ret = CloseClipboard()
    GetClipboardEnhMetaFile = hmf2
    Exit Function
ErrorHandler:
    Ret = CloseClipboard()
End Function


Public Sub SaveBitmapFromClipboardMetafile()
    Dim hemf As Long
    Dim hdc As Long
    Dim cntFile As Long
    Dim rc As RECT
    Dim Ret As Long
    Dim Path As String

    If Val(Application.Version) < 9 Then
        MsgBox "Excel 2000 以降で動作します。", vbExclamation
        Exit Sub
    End If
    If TypeName(Selection) = "Range" Then
        MsgBox "拡張メタファイルを選択して実行してください。", vbExclamation
        Exit Sub
    End If
    Selection.Copy
    hemf = GetClipboardEnhMetaFile()
    If hemf = 0 Then
        MsgBox "拡張メタファイルを選択して実行してください。", vbExclamation
        Exit Sub
    End If

    On Error Resume Next
    Path = CurDir()
    MsgBox "次に表示されるダイアログボックスで、保存するフォルダを開き、[開く]または[キャンセル]を押してください。", vbInformation
    Application.GetOpenFilename
    If MsgBox(CurDir() & " に " & PREFIX & "001.BMP〜" & PREFIX & "999.BMP を作成します。" & vbNewLine & _
            "同名ファイルは上書きされます。実行しますか？", _
            vbExclamation Or vbDefaultButton2 Or vbOKCancel) <> vbOK Then
        DeleteEnhMetaFile hemf
        ChDrive Path
        ChDir Path
        Exit Sub
    End If

    cntFile = 0
    rc.Right = 10
    rc.Bottom = 10
    hdc = GetDC(0)
    Ret = EnumEnhMetaFile(hdc, hemf, AddressOf EnumEnhMetaFileProc, cntFile, rc)
    ReleaseDC 0, hdc
    DeleteEnhMetaFile hemf
    If cntFile > 0 Then
        MsgBox CurDir() & " に " & cntFile & " 個のBMPファイルを作成しました。", vbInformation
    Else
        MsgBox "拡張メタファイルにビットマップは見つかりませんでした。", vbInformation
    End If
    ChDrive Path
    ChDir Path
End Sub