'Save Picture as WMF
'    for Excel 95 or later for Windows

'Insert a new module, copy the following code and paste to the module.
'Select cell range or drawing object, then run the "SaveAsWMF" macro.


Option Explicit

Private Const sAppName As String = "Save Picture as WMF"

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

    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


Public Sub SaveAsWMF()
    Dim iErr As Long, iRet As Long
    Dim vFileName As Variant

    iRet = MsgBox("Copy picture of selected object?", _
        vbExclamation Or vbYesNoCancel, sAppName)
    If iRet = vbCancel Then Exit Sub
    If iRet = vbYes Then
        If Not SelectionCopyPicture() Then
            MsgBox "Error copying picture of selected object.", _
                vbExclamation, sAppName
            Exit Sub
        End If
    End If

    If Not IsClipboardFormatWMF() Then
        MsgBox "No picture in clipboard.", _
            vbExclamation, sAppName
        Exit Sub
    End If

    vFileName = Application.GetSaveAsFilename( _
        InitialFilename:="", _
        FileFilter:="Windows Metafiles (*.wmf),*.wmf,All files (*.*),*.*")
    If VarType(vFileName) = vbBoolean Then Exit Sub
    If Dir$(vFileName) <> "" Then
        iRet = MsgBox("The file '" & vFileName & _
            "' already exists. Replace existing file?", _
            vbExclamation Or vbOKCancel Or vbDefaultButton2, sAppName)
        If iRet <> vbOK Then Exit Sub
    End If

    iRet = SaveClipboardMetaFile(vFileName)
    If iRet = 0 Then
        MsgBox "The picture was saved.", vbExclamation, sAppName
    Else
        MsgBox "Unexpected error.", vbExclamation, sAppName
    End If
End Sub