将 Excel 个图表导出为 *.emf

Question

我发现 post 正在调查，但不幸的是没有回答我想到的问题 如何从 EXCEL 导出图表为 *.EMF

Excel export chart to wmf or emf?

提供的代码对我不起作用。我所做的是像这样扩展每个“Private Declare Function”“Private Declare PtrSafe 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

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

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

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

Answer 1

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

Answer 2

在注释掉 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.

所必需的

将 Excel 个图表导出为 *.emf

export Excel graphs as *.emf

excel

vba

vector-graphics