将 Excel 图表导出为 *.emf

Question

我发现该帖子正在调查，但不幸的是没有回答我想到的问题 如何将 EXCEL 中的图形导出为 *.EMF

Excel export chart to wmf or emf?

提供的代码对我不起作用。 我所做的是像“Private Declare PtrSafe Function”一样​​扩展每个“Private Declare Function”，使其适用于64BIT。

代码：

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

我想使用此代码将带有工作表名称的工作表中的图形自动导出到循环内的特定文件夹中，以防万一。如果可以通过按钮执行，则突出显示。

到目前为止，当我运行代码时，我得到的只是一条“未保存”消息。我正在使用 Excel 365 ProPlus，以防万一。

如果有人能解释一下这段代码是如何工作的以及我需要在那里实现什么，我将不胜感激

Answer 1

在注释掉 Charts.add 行并将写入目标更改为我有写入权限的路径后，OP 代码对我有用

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

这实际上与 @kuv 的答案相同，但在 windows 函数调用中添加了 PtrSafe 修饰符（这些是 64 位 excel 所必需的。

Answer 2

这是我使用的一些代码，直接模仿人类交互的 user32 函数是我通过 vba 将聊天保存为不同格式的唯一方法，它当前的语句也适用于活动工作表/工作簿，显然可以如果您构建一个仪表板，其中图表保留在其他工作表上，则进行更改，如果您有任何疑问，您可以通过 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