'選択オブジェクトの画像をWMFファイルへ保存するマクロ

Option Explicit

Private Type METAFILEPICT
    mm As Long
    xExt As Long
    yExt As Long
    hmf As Long
End Type

Private Const GHND = &h42
Private Const CF_METAFILEPICT = 3

Private Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_WRITE = &h40000000
Private Const CREATE_ALWAYS = &h2
Private Const FILE_ATTRIBUTE_ARCHIVE = &h20

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 CopyMetaFile Lib "gdi32" Alias "CopyMetaFileA" ( _
    ByVal hmf As Long, ByVal lpFileName As Long) As Long
Private Declare Function DeleteMetaFile Lib "gdi32" ( _
    ByVal hmf As Long) As Long
Private Declare Function GetMetaFileBitsEx Lib "gdi32" ( _
    ByVal hmf As Long, ByVal nSize As Long, _
    ByRef lpvData As Any) As Long

Private Declare Function GlobalLock Lib "kernel32" ( _
    ByVal hMEM As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" ( _
    ByVal hMEM As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" ( _
    ByVal wFlags As Long, ByVal wBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMEM As Long) As Long

Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
    ByVal lpszName As String, ByVal dwAccess As Long, _
    ByVal dwShareMode As Long, ByVal lpsa As Long, _
    ByVal dwCreate As Long, ByVal dwAttrsAndFlags As Long, _
    ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WriteFile Lib "kernel32" ( _
    ByVal hFile As Long, ByRef lpBuffer As Any, _
    ByVal nNumberOfBytesToWrite As Long, ByRef lpNumberOfBytesWritten As Long, _
    ByVal lpOverlapped 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)


'クリップボードにメタファイルがあるかチェックする関数
Public Function IsClipboardFormatWMF()
    IsClipboardFormatWMF = _
        (IsClipboardFormatAvailable(CF_METAFILEPICT) <> 0)
End Function


'クリップボードのメタファイルをファイルに保存する関数
Public Function SaveClipboardMetaFile( _
        ByVal sFileName As String) As Long
    Dim mfp As METAFILEPICT
    Dim a(0 To 10) As Integer
    Dim hmf As Long, hFile As Long, hglb As Long
    Dim iSize As Long, lpBuffer As Long
    Dim i As Long, iRet As Long, iWritten As Long

    On Error GoTo ErrorHandler

    SaveClipboardMetaFile = -1

    iRet = GetClipboardMetaFile(mfp)
    If iRet <> 0 Then Exit Function

    hmf = mfp.hmf

    a(0) = &hcdd7
    a(1) = &h9ac6
    If mfp.mm = 8 Then
        a(5) = Int(mfp.xExt / 2.54)
        a(6) = Int(mfp.yExt / 2.54)
    End If
    If (a(5) <= 0) Or (a(6) <= 0) Then
        a(5) = 1000
        a(6) = 1000
    End If
    a(7) = &h3e8
    For i = 0 To 9
        a(10) = a(10) Xor a(i)
    Next

    iSize = GetMetaFileBitsEx(hmf, 0, ByVal 0&)
    If iSize = 0 Then GoTo exit_DeleteMetaFile

    hglb = GlobalAlloc(GHND, iSize)
    If hglb = 0 Then GoTo exit_DeleteMetaFile

    lpBuffer = GlobalLock(hglb)
    If lpBuffer = 0 Then GoTo exit_GlobalFree

    iRet = GetMetaFileBitsEx(hmf, iSize, ByVal lpBuffer)
    If iRet <> iSize Then GoTo exit_GlobalUnlock

    hFile = CreateFile(sFileName, GENERIC_WRITE, 0, 0, CREATE_ALWAYS, _
        FILE_ATTRIBUTE_ARCHIVE, 0)
    If hFile = INVALID_HANDLE_VALUE Then GoTo exit_CloseFile

    iRet = WriteFile(hFile, a(0), 22, iWritten, 0)
    If iRet = 0 Then GoTo exit_CloseFile

    iRet = WriteFile(hFile, ByVal lpBuffer, iSize, iWritten, 0)
    If iRet = 0 Then GoTo exit_CloseFile

    iRet = CloseHandle(hFile)
    If iRet = 0 Then GoTo exit_GlobalUnlock
    hFile = 0

    iRet = GlobalUnlock(hglb)
    If iRet <> 0 Then GoTo exit_GlobalFree

    iRet = GlobalFree(hglb)
    If iRet <> 0 Then GoTo exit_DeleteMetaFile
    hglb = 0

    iRet = DeleteMetaFile(hmf)
    If iRet = 0 Then Exit Function
    hmf = 0

    SaveClipboardMetaFile = 0
    Exit Function

exit_CloseFile:
    iRet = CloseHandle(hFile)
    hFile = 0
exit_GlobalUnlock:
    iRet = GlobalUnlock(hglb)
exit_GlobalFree:
    iRet = GlobalFree(hglb)
    hglb = 0
exit_DeleteMetaFile:
    iRet = DeleteMetaFile(hmf)
    hmf = 0
    Exit Function

ErrorHandler:
    If (hFile <> 0) And (hFile <> INVALID_HANDLE_VALUE) Then _
        iRet = CloseHandle(hFile)
    If hglb <> 0 Then
        iRet = GlobalUnlock(hglb)
        iRet = GlobalFree(hglb)
    End If
    If hmf <> 0 Then iRet = DeleteMetaFile(hmf)
End Function


'クリップボードのメタファイルをコピーする関数
Private Function GetClipboardMetaFile(ByRef mfp As METAFILEPICT) As Long
    Dim lpmfp As Long, hglb As Long
    Dim hmf As Long, iRet As Long

    On Error GoTo ErrorHandler

    GetClipboardMetaFile = 2

    'メタファイルかチェック
    If IsClipboardFormatAvailable(CF_METAFILEPICT) = 0 Then
        GetClipboardMetaFile = 1
        Exit Function
    End If

    'クリップボードのオープン
    If OpenClipboard(0) = 0 Then Exit Function

    'クリップボードのメモリハンドルを取得
    hglb = GetClipboardData(CF_METAFILEPICT)
    If hglb = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    'グローバルメモリをロック
    lpmfp = GlobalLock(hglb)
    If lpmfp = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    'METAFILEPICT構造体をコピー
    MoveMemory mfp, ByVal lpmfp, 16

    'グローバルメモリのロック解除
    iRet = GlobalUnlock(hglb)
    hglb = 0

    'メタファイルをコピー
    hmf = CopyMetaFile(mfp.hmf, 0)
    If hmf = 0 Then
        iRet = CloseClipboard()
        Exit Function
    End If

    'クリップボードをクローズ
    iRet = CloseClipboard()

    mfp.hmf = hmf
    GetClipboardMetaFile = 0
    Exit Function

ErrorHandler:
    If hglb <> 0 Then iRet = GlobalUnlock(hglb)
    iRet = CloseClipboard()
    If hmf <> 0 Then iRet = DeleteMetaFile(hmf)
End Function


'選択オブジェクトの画像をコピーする関数
'グラフがアクティブのときはグラフ全体をコピーします。

Private Function SelectionCopyPicture() As Boolean
    Dim iLineNo As Integer, iStatus As Integer

    On Error GoTo ErrorHandler

    iLineNo = 1
    If Not (ActiveChart Is Nothing) Then
        ActiveChart.CopyPicture Appearance:=xlScreen, _
            Format:=xlPicture, Size:=xlScreen
        SelectionCopyPicture = True
        Exit Function
    End If

    iLineNo = 2
    iStatus = 0
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlPicture, Size:=xlScreen
    If iStatus = 0 Then
        SelectionCopyPicture = True
        Exit Function
    End If

    iLineNo = 3
    Selection.CopyPicture Appearance:=xlScreen, _
        Format:=xlPicture
    SelectionCopyPicture = True

    Exit Function

ErrorHandler:
    Select Case iLineNo
        Case 2
            iStatus = 1
            Resume Next
        Case Else
            SelectionCopyPicture = False
            Exit Function
    End Select
End Function


'選択オブジェクトの画像をWMFファイルへ保存するマクロ
Public Sub SaveAsWMF()
    Const MyTitle As String = "画像コピーをWMFファイルへ保存"
    Dim iErr As Long, iRet As Long
    Dim vFileName As Variant

    iRet = MsgBox("選択オブジェクトの画像をコピーしますか？", _
        vbExclamation Or vbYesNoCancel, MyTitle)
    If iRet = vbCancel Then Exit Sub
    If iRet = vbYes Then
        If Not SelectionCopyPicture() Then
            MsgBox "選択オブジェクトの画像コピーに失敗しました。", _
                vbExclamation, MyTitle
            Exit Sub
        End If
    End If

    If Not IsClipboardFormatWMF() Then
        MsgBox "クリップボードに図がありません。", _
            vbExclamation, MyTitle
        Exit Sub
    End If

    vFileName = Application.GetSaveAsFilename( _
        InitialFilename:="", _
        FileFilter:=StrConv("Windows メタファイル (*.wmf),*.wmf," & _
        "すべてのファイル (*.*),*.*", vbNarrow), Title:=MyTitle)
    If VarType(vFileName) = vbBoolean Then Exit Sub
    If Dir$(vFileName) <> "" Then
        iRet = MsgBox("ファイルは既に存在します。上書きしますか？", _
            vbExclamation Or vbOKCancel Or vbDefaultButton2, MyTitle)
        If iRet <> vbOK Then Exit Sub
    End If

    iRet = SaveClipboardMetaFile(vFileName)
    If iRet <> 0 Then
        MsgBox "エラーが発生しました。", vbExclamation, MyTitle
    End If
End Sub