VBA实用小程序5１：将图表导出为图片（API版）

fanjy

发布于 2019-07-19 15:38:10

1.7K0

发布于 2019-07-19 15:38:10

文章被收录于专栏：完美Excel 完美Excel完美Excel

学习Excel技术，关注微信公众号：

excelperfect

在前面的VBA实用小程序15和16中，我们给出了两个将Excel图表导出为图片的VBA程序，详见下面的链接：

VBA实用小程序15：将Excel图表导出为图片

VBA实用小程序16：将Excel图表导出为图片（增强版）

这里给出的小程序来自dailydoseofexcel.com，使用Windows API来将Excel图表导出为图片。代码如下：

Declare Function OpenClipboard _
    Lib "user32" _
    (ByVal hwnd As Long) As Long
Declare Function CloseClipboard _
    Lib "user32" () As Long
Declare Function GetClipboardData _
    Lib "user32" _
    (ByVal wFormat As Long) As Long
Declare Function EmptyClipboard _
    Lib "user32" () As Long
Declare Function CopyEnhMetaFileA _
    Lib "gdi32" _
    (ByVal hENHSrc As Long, _
    ByVal lpszFile As String) As Long
Declare Function DeleteEnhMetaFile _
    Lib "gdi32" _
    (ByVal hemf As Long) As Long
Const CF_ENHMETAFILE As Long = 14
Const cInitialFilename= "Picture1.emf"
Const cFileFilter ="扩展的Windows图元文件(*.emf), *.emf"
Public Sub SaveAsEMF()
    Dim var As Variant, lng As Long
    var = Application.GetSaveAsFilename _
        (cInitialFilename, cFileFilter)
    If VarType(var) <> vbBoolean Then
        On Error Resume Next
        Selection.Copy
        OpenClipboard 0
        lng = GetClipboardData(CF_ENHMETAFILE)
        lng = CopyEnhMetaFileA(lng, var)
        EmptyClipboard
        CloseClipboard
        DeleteEnhMetaFile lng
        On Error GoTo 0
    End If
End Sub

注意，在运行SaveAsEMF过程之前，需要先选中Excel图表。

程序代码的图片版如下：