export Excel graphs as *.emf

Question

I found that post investigating, but unfortunately not answering the question which came to my mind on HOW TO EXPORT GRAPHS FROM EXCEL AS *.EMF

Excel export chart to wmf or emf?

The code presented is not working for me. What I did is to extend each "Private Declare Function" like this "Private Declare PtrSafe Function" to make it applicable for 64BIT.

CODE:

Option Explicit

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

Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

Private Declare PtrSafe Function GetClipboardData _
Lib "user32" ( _
    ByVal wFormat As Long) _
As Long

Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long

'// CreateMetaFileA DeleteEnhMetaFile
Private Declare PtrSafe Function CopyEnhMetaFileA _
Lib "gdi32" ( _
    ByVal hENHSrc As Long, _
    ByVal lpszFile As String) _
As Long

Private Declare PtrSafe Function DeleteEnhMetaFile _
Lib "gdi32" ( _
    ByVal hemf As Long) _
As Long

Public Function fnSaveAsEMF(strFileName As String) As Boolean
Const CF_ENHMETAFILE As Long = 14

Dim ReturnValue As Long

OpenClipboard 0

ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE),   strFileName)

EmptyClipboard

CloseClipboard

'// Release resources to it eg You can now delete it if required
'// or write over it. This is a MUST
DeleteEnhMetaFile ReturnValue

fnSaveAsEMF = (ReturnValue <> 0)

End Function

Sub SaveIt()
Charts.Add
ActiveChart.ChartArea.Select
Selection.Copy
If fnSaveAsEMF("C:\Excel001.emf") Then
    MsgBox "Saved", vbInformation
Else
    MsgBox "NOT Saved!", vbCritical
End If

I want to use this code to export graphs from worksheets with their worksheet name automatically to a specific folder within a loop in case thats possible. Highlight would be if its possible to execute that via a button.

So far when i run the code All I get is a "NOT SAVED" message. Im using Excel 365 ProPlus, in case thats of any relevance.

I would highly appreciate if someone would explain me how this code is working and what i need to implement there

@BigBen: I attached the vba code I used. – Olli Mar 16 '20 at 19:56 — Olli, Mar 16 '20 at 19:56

score 0 · Answer 1 · answered Mar 16 '20 at 13:26

this is some code that i have used, the user32 function which imitates human interaction directly is the only way ive come across to save chats as different formats via vba, also its current statements are for an active sheet/workbook which can obviously be altered if you building a dashboard where the charts remain on other sheets, if you have any queries you can email me on howtovba@gmail.com;

Option Explicit

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 EmptyClipboard Lib "user32" () As Long

'// CreateMetaFileA DeleteEnhMetaFile
Private Declare Function CopyEnhMetaFileA _
    Lib "gdi32" ( _
        ByVal hENHSrc As Long, _
        ByVal lpszFile As String) _
As Long

Private Declare Function DeleteEnhMetaFile _
    Lib "gdi32" ( _
        ByVal hemf As Long) _
As Long


Public Function fnSaveAsEMF(strFileName As String) As Boolean
Const CF_ENHMETAFILE As Long = 14

Dim ReturnValue As Long

    OpenClipboard 0

    ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName)

    EmptyClipboard

    CloseClipboard

    '// Release resources to it eg You can now delete it if required
    '// or write over it. This is a MUST
    DeleteEnhMetaFile ReturnValue

    fnSaveAsEMF = (ReturnValue <> 0)

End Function

Sub SaveIt()
Charts.Add
    ActiveChart.ChartArea.Select
    Selection.Copy
    If fnSaveAsEMF("C:\Excel001.emf") Then 'the name excluding the .emf can be changed
        MsgBox "Saved", vbInformation
    Else
        MsgBox "NOT Saved!", vbCritical
    End If

End Sub

hi @kuv. i just receive a "not saved" as reply executing that vba code. how can i adjust that to work properly? — Olli, Mar 19 '20 at 12:32

score 0 · Accepted Answer · answered Jun 18 '21 at 17:37

The OP code worked for me after commenting out the Charts.add line and changing the write destination to a path where I had write privileges

Option Explicit

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

Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

Private Declare PtrSafe Function GetClipboardData _
    Lib "user32" ( _
    ByVal wFormat As Long) _
    As Long

Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long

'// CreateMetaFileA DeleteEnhMetaFile
Private Declare PtrSafe Function CopyEnhMetaFileA _
    Lib "gdi32" ( _
    ByVal hENHSrc As Long, _
    ByVal lpszFile As String) _
    As Long

Private Declare PtrSafe Function DeleteEnhMetaFile _
    Lib "gdi32" ( _
    ByVal hemf As Long) _
    As Long


Public Function fnSaveAsEMF(strFileName As String) As Boolean
    Const CF_ENHMETAFILE As Long = 14

    Dim ReturnValue As Long

    OpenClipboard 0

    ReturnValue = CopyEnhMetaFileA(GetClipboardData(CF_ENHMETAFILE), strFileName)

    EmptyClipboard

    CloseClipboard

    '// Release resources to it eg You can now delete it if required
    '// or write over it. This is a MUST
    DeleteEnhMetaFile ReturnValue

    fnSaveAsEMF = (ReturnValue <> 0)

End Function

Sub SaveIt()
    'Charts.Add
    ActiveChart.ChartArea.Select
    Selection.Copy
    If fnSaveAsEMF("m:\mpo\autompo\test.emf") Then 'the name excluding the .emf can be changed
                                                    'Be sure you have write privileges here or you will get an error
            MsgBox "Saved", vbInformation
        Else
            MsgBox "NOT Saved!", vbCritical
        End If

End Sub

This is effectively the same answer as @kuv , but adds in the PtrSafe modifier to the windows function calls (these are required with 64 bit excel.

export Excel graphs as *.emf

2 Answers2