将 Excel 图表导出到 SVG 会创建一个空文件

Question

我正在尝试使用 VBA 以 SVG 格式导出 Excel 图表。

    Set objChrt = ActiveChart.Parent
    objChrt.Activate
    Set curChart = objChrt.Chart
    
    curChart.Export fileName:=fileName, FilterName:="SVG"

如果我将“SVG”替换为“PNG”，导出将完全按照预期工作并生成有效的 PNG 文件。但是，“SVG”会生成一个空文件。 （手动在 Excel 365 中可以选择另存为 SVG，因此存在导出过滤器）。

根据文档，Filtername 是“出现在注册表中的图形过滤器的与语言无关的名称。”，但我在注册表中找不到类似的东西，无论哪种方式，都很难想象SVG 过滤器名称被命名为“SVG”以外的任何名称。

有没有办法使用 VBA 以 SVG 格式导出图表？

---

注意：还有一个关于 Chart.export 生成空文件的问题，解决方法是在导出前使用ChartObject.Activate。这个问题是不同的，因为代码可以正确使用“PNG”但无法使用“SVG”（因此这不是与激活或可见性相关的问题）。建议的修复也不起作用。

Answer 1

当您将图表复制到剪贴板时，Excel 会添加许多不同的剪贴板格式。从version 2011 开始，现在包括“image/svg+xml”。

所以我们要做的就是在剪贴板上找到该格式并将其保存到文件中。事实证明这很烦人。

Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" _
    Alias "GetClipboardFormatNameW" _
    (ByVal wFormat As Long, _
    ByVal lpString As LongPtr, _
    ByVal nMaxCount As Integer) As Integer
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

Private Declare PtrSafe Function GlobalUnlock Lib "Kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "Kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalSize Lib "Kernel32" (ByVal hMem As LongPtr) As LongPtr

Private Declare PtrSafe Function CreateFile Lib "Kernel32" _
    Alias "CreateFileA" (ByVal lpFileName As String, _
    ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, _
    ByVal lpSecurityAttributes As LongPtr, _
    ByVal dwCreationDisposition As Long, _
    ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As LongPtr) As LongPtr

Private Declare PtrSafe Function WriteFile Lib "Kernel32" _
    (ByVal hFile As LongPtr, _
    ByVal lpBuffer As LongPtr, _
    ByVal nNumberOfBytesToWrite As Long, _
    ByRef lpNumberOfBytesWritten As Long, _
    ByVal lpOverlapped As LongPtr) As Long

Private Declare PtrSafe Function CloseHandle Lib "Kernel32" (ByVal hObject As LongPtr) As Long


Sub SaveClipboard(formatName As String, filename As String)
    Dim fmtName As String
    Dim fmt As Long
    Dim length As Long
    Dim wrote As Long
    Dim data As LongPtr
    Dim fileHandle As LongPtr
    Dim content As LongPtr
    Dim ret As Long
    
    If OpenClipboard(ActiveWindow.hwnd) = 0 Then
        Exit Sub
    End If
    
    fmt = 0
    Do
        fmt = EnumClipboardFormats(fmt)
        If fmt = 0 Then Exit Do
        
        fmtName = String$(255, vbNullChar)
        length = GetClipboardFormatName(fmt, StrPtr(fmtName), 255)
        If length <> 0 And Left(fmtName, length) = formatName Then
            data = GetClipboardData(fmt)
            
            length = GlobalSize(data)
            content = GlobalLock(data)

            ' use win32 api file handling to avoid copying buffers
            fileHandle = CreateFile(filename, &H120089 Or &H120116, 0, 0, 2, 0, 0)
            ret = WriteFile(fileHandle, content, length, wrote, 0)
            CloseHandle fileHandle
            
            GlobalUnlock data
            Exit Do
        End If
    Loop

    CloseClipboard
    
    If fmt = 0 Then
        MsgBox "Did not find clipboard format " & formatName
        Exit Sub
    End If

End Sub

然后只需复制图表并保存 svg；

shape.Copy
SaveClipboard "image/svg+xml", "C:\temp\output.svg"

Answer 2

仅使用 Excel 和 VBA 导出到 .svg，无需任何外部应用程序

我不得不创建一个新答案，因为我的另一个答案中没有足够的空间。就个人而言，我更喜欢使用此解决方案，因为没有外部依赖项。

我现在可以自信地回答这个问题：有没有办法使用 VBA 以 SVG 格式导出图表？

是的。

这是一个hacky混乱，但它现在可以工作......至少在我的机器上。

我尝试为代码创建一个简单的界面，这样您就不必真正理解它来使用它。不过，首先我将解释它是如何工作的，存在哪些必须克服的问题，以及我是如何设法解决这些问题的。然后，我给出了一个简短的使用示例和说明。所以如果你对技术不感兴趣，你可以跳到简单的部分。

什么想法？

代码基本上尝试使用手动导出方法。这有几个问题，第一个是Chart.Export 方法中的另一个错误。 Chart.Export Interactive:=True is supposed to 打开所需的对话框，但这不起作用。通过利用很少使用甚至未记录的快捷方式（可能不是，但我必须使用蛮力方法找到其中一个），可以使用SendKeys "+{F10}" 后跟SendKeys "g" 非常可靠地打开导出窗口。第一关已经跨过了，麻烦才刚刚开始！

事实证明，打开模态对话框会停止工作簿中的所有代码执行。不，不仅在工作簿中，在整个应用程序中。即使我们在打开对话框之前调用另一个应用程序实例中的代码，我们如何才能让它在那里运行并同时返回以完成打开对话框？这听起来不可能，因为 VBA 是严格的单线程...

好吧，事实证明，单线程并不是那么严格:) 解决方案称为Application.OnTime，它在未来的预定时间启动一个过程。该过程必须在Excel.Application 的不同实例中运行，因为Application.OnTime 只会在应用程序处于某些模式（就绪、复制、剪切或查找）并且正在运行 VBA 代码或具有模式对话框时启动一个过程open 肯定不在其中。因此，在打开对话框之前，我们必须创建 Excel 应用程序的后台实例，将 VBA 代码插入其中并调用该代码，然后一旦对话框打开，它将安排其他代码在后台实例中开始运行。注意：因为我们要自动将代码插入到后台实例中，所以需要开启Trust access to the VBA project object model。

下一个问题是：我们如何仅使用 VBA 代码来处理 Windows 对话框？我非常努力地避免更多SendKeys，但不幸的是，有些问题超出了我的范围。我设法通过EnumChildWindows 获取对话框的所有窗口和控制句柄，并使用这些信息将文本插入“文件名”组合框。由于您也可以在那里插入路径，剩下的唯一问题是在 FileFormat ComboBox 中选择“.svg”并单击“保存”按钮。

使用 Windows API 函数更改 Combobox 中的选择相对容易，但问题是要真正让它注册更改。它似乎在对话框中发生了变化，但是当我单击“保存”时，它仍然保存为 .png。我花了几个小时在 Spy++ 中监视手动更改期间发送的消息，但我无法使用 VBA 重现它们。该语言对于低级任务来说确实很糟糕，试图将位与 VBA 对齐是一种痛苦。无论如何，正因为如此，它必须再次SendKeys 才能更改文件格式并按“保存”。

我尝试对SendKeys 的使用非常小心，实施各种安全检查，并在每次使用前将目标窗口拉到前面，但你永远无法做到 100% 安全。

因为该方法需要应用程序onceagain 的后台实例，所以我再次为ShapeExporter 对象实现了一个类。创建对象会打开后台应用程序，销毁对象会关闭它。

简单使用指南

以下过程会将指定工作表中的所有ChartObjects导出到保存工作簿的文件夹中。

Sub ExportEmbeddedChartToSVG()
    Dim MyWorksheet As Worksheet
    Set MyWorksheet = Application.Worksheets("MyWorksheet")
    
    'Creating the ShapeExporter object
    Dim oShapeExporter As cShapeExporter
    Set oShapeExporter = New cShapeExporter
    
    'Export as many shapes as you want here, before destroying oShapeExporter
    Dim oChart As ChartObject
    For Each oChart In MyWorksheet.ChartObjects
        'the .ExportShapeAsSVG method of the object takes three arguments:
        '1. The Chart or Shape to be exported
        '2. The target filename
        '3. The target path
        oShapeExporter.ExportShapeAsSVG oChart, oChart.Name, ThisWorkbook.Path
    Next oChart
    
    'When the object goes out of scope, its terminate procedure is automatically called
    'and the background app is closed
    Set oShapeExporter = Nothing
End Sub

要使代码正常工作，您必须首先：

1. Trust access to the VBA project object model（原因见宏的详细说明）
2. 创建一个类模块，将其重命名为“cShapeExporter”，并将以下代码粘贴到其中：

'Class for automatic exporting in SVG-Format
'Initial author: Guido Witt-Dörring, 09.12.2020
'https://stackoverflow.com/a/65212838/12287457

'Note:
'When objects created from this class are not properly destroyed, an invisible 
'background instance of Excel will keep running on your computer. In this 
'case, you can just close it via the Task Manager.
'For example, this will happen when your code hits an 'End' statement, which 
'immediately stops all code execution, or when an unhandled error forces 
'you to stop code execution manually while an instance of this class exists.

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hWnd As LongPtr) As Boolean
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Boolean
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hWnd As LongPtr) As Boolean
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long)
    Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Boolean
    Private Declare Function IsWindowVisible Lib "User32" (ByVal hWnd As Long) As Boolean
    Private Declare Function IsIconic Lib "User32" Alias "IsIconic" (ByVal hWnd As long) As boolean
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

Private NewXlAppInstance As Excel.Application
Private xlWbInOtherInstance As Workbook
    
Private Sub Class_Initialize()
    Set NewXlAppInstance = New Excel.Application
    Set xlWbInOtherInstance = NewXlAppInstance.Workbooks.Add
    
    NewXlAppInstance.Visible = False
    
    On Error Resume Next
    xlWbInOtherInstance.VBProject.References.AddFromFile "scrrun.dll"
    xlWbInOtherInstance.VBProject.References.AddFromFile "FM20.dll"
    On Error GoTo 0
    
    Dim VbaModuleForOtherInstance As VBComponent
    Set VbaModuleForOtherInstance = xlWbInOtherInstance.VBProject.VBComponents.Add(vbext_ct_StdModule)
    
    VbaModuleForOtherInstance.CodeModule.AddFromString CreateCodeForOtherXlInstance
End Sub

Private Sub Class_Terminate()
    NewXlAppInstance.DisplayAlerts = False
    NewXlAppInstance.Quit
    Set xlWbInOtherInstance = Nothing
    Set NewXlAppInstance = Nothing
End Sub

Public Sub ExportShapeAsSVG(xlShp As Object, FileName As String, FilePath As String)
    'Check if path exists:
    If Not ExistsPath(FilePath) Then
        If vbYes = MsgBox("Warning, you are trying to export a file to a path that doesn't exist! Continue exporting to default path? " & vbNewLine & "Klick no to resume macro without exporting or cancel to debug.", vbYesNoCancel, "Warning") Then
            FilePath = ""
        ElseIf vbNo Then
            Exit Sub
        ElseIf vbCancel Then
            Error 76
        End If
    End If
    If TypeName(xlShp) = "ChartObject" Or TypeName(xlShp) = "Shape" Or TypeName(xlShp) = "Chart" Or TypeName(xlShp) = "ChartArea" Then
        'fine
    Else
        MsgBox "Exporting Objects of type " & TypeName(xlShp) & " not supported, sorry."
        Exit Sub
    End If
    
    If TypeName(xlShp) = "ChartArea" Then Set xlShp = xlShp.Parent
    
retry:
    SetForegroundWindow FindWindow("XLMAIN", ThisWorkbook.Name & " - Excel")
    
    If Not Application.Visible Then 'Interestingly, API function "IsWindowVisible(Application.hWnd)" doesn't work here! (maybe because of multi monitor setup?)
        MsgBox "The workbook must be visible for the svg-export to proceed! It must be at least in window mode!"
        Application.WindowState = xlNormal
        Application.Visible = True
        Sleep 100
        GoTo retry
    End If
    
    If IsIconic(Application.hWnd) Then 'Interestingly "Application.WindowState = xlMinimized" doesn't work here!"
        MsgBox "The workbook can't be minimized for the svg-export to proceed! It must be at least in window mode!"
        Application.WindowState = xlNormal
        Sleep 100
        GoTo retry
    End If
    
    'check if background instance still exists and start support proc
    On Error GoTo errHand
    NewXlAppInstance.Run "ScheduleSvgExportHelperProcess", Application.hWnd, ThisWorkbook.Name, FileName, FilePath
    On Error GoTo 0
    
    Sleep 100

    xlShp.Activate
    
    SetForegroundWindow FindWindow("XLMAIN", ThisWorkbook.Name & " - Excel")
    SendKeys "+{F10}"
    DoEvents
    SendKeys "g"
    DoEvents
    Exit Sub
errHand:
    MsgBox "Error in ShapeExporter Object. No more shapes can be exported."
    Err.Raise Err.Number
End Sub

Public Function ExistsPath(ByVal FilePath As String) As Boolean
    Dim oFso As Object
    Dim oFolder As Object
    
    Set oFso = CreateObject("Scripting.FileSystemObject")
    'Setting the Folder of the Filepath
    On Error GoTo PathNotFound
    Set oFolder = oFso.GetFolder(Left(Replace(FilePath & "\", "\\", "\"), Len(Replace(FilePath & "\", "\\", "\")) - 1))
    On Error GoTo 0
    
    ExistsPath = True
    Exit Function
    
PathNotFound:
    ExistsPath = False
End Function

Private Function CreateCodeForOtherXlInstance() As String
    Dim s As String
    s = s & "Option Explicit" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "#If VBA7 Then" & vbCrLf
    s = s & "    Public Declare PtrSafe Sub Sleep Lib ""kernel32"" (ByVal dwMilliseconds As Long)" & vbCrLf
    s = s & "    Private Declare PtrSafe Function GetForegroundWindow Lib ""user32"" () As LongPtr" & vbCrLf
    s = s & "    Private Declare PtrSafe Function GetWindowText Lib ""user32"" Alias ""GetWindowTextA"" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long" & vbCrLf
    s = s & "    Private Declare PtrSafe Function FindWindow Lib ""user32"" Alias ""FindWindowA"" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr" & vbCrLf
    s = s & "    Private Declare PtrSafe Function SetForegroundWindow Lib ""user32"" (ByVal hWnd As LongPtr) As Boolean" & vbCrLf
    s = s & "    Private Declare PtrSafe Function SendMessage Lib ""user32"" Alias ""SendMessageA"" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr" & vbCrLf
    s = s & "    Private Declare PtrSafe Function GetClassName Lib ""user32"" Alias ""GetClassNameA"" (ByVal hWnd As LongPtr, ByVal lpStr As String, ByVal nMaxCount As Long) As Long" & vbCrLf
    s = s & "    Private Declare PtrSafe Function EnumChildWindows Lib ""user32"" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Boolean" & vbCrLf
    s = s & "    Private Declare PtrSafe Function GetWindowTextLength Lib ""user32"" Alias ""GetWindowTextLengthA"" (ByVal hWnd As LongPtr) As Long" & vbCrLf
    s = s & "    Private Declare PtrSafe Function GetWindowLongPtr Lib ""user32"" Alias ""GetWindowLongPtrA"" (ByVal hWnd As LongPtr, ByVal nindex As Long) As LongPtr" & vbCrLf
    s = s & "#Else" & vbCrLf
    s = s & "    Public Declare Sub Sleep Lib ""kernel32"" (ByVal lngMilliSeconds As Long)" & vbCrLf
    s = s & "    Private Declare Function GetForegroundWindow Lib ""user32"" () As Long" & vbCrLf
    s = s & "    Private Declare Function GetWindowText Lib ""user32"" Alias ""GetWindowTextA"" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long" & vbCrLf
    s = s & "    Private Declare Function FindWindow Lib ""user32"" Alias ""FindWindowA"" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long" & vbCrLf
    s = s & "    Private Declare Function SetForegroundWindow Lib ""user32"" (ByVal hwnd As Long) As Boolean" & vbCrLf
    s = s & "    Private Declare Function SendMessage Lib ""user32"" Alias ""SendMessageA"" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long" & vbCrLf
    s = s & "    Private Declare Function GetClassName Lib ""user32"" Alias ""GetClassNameA"" (ByVal hwnd As Long, ByVal lpStr As String, ByVal nMaxCount As Long) As Long" & vbCrLf
    s = s & "    Private Declare Function EnumChildWindows Lib ""User32"" (ByVal hwndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As boolean" & vbCrLf
    s = s & "    Private Declare Function GetWindowTextLength Lib ""User32"" Alias ""GetWindowTextLengthA"" (ByVal hwnd As Long) As Long" & vbCrLf
    s = s & "    Private Declare Function GetWindowLongPtr Lib ""User32"" Alias ""GetWindowLongPtrA"" (ByVal hwnd As Long, ByVal nindex As Long) As Long" & vbCrLf
    s = s & "#End If" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "Private Const GWL_ID = -12" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "Private Const WM_SETTEXT = &HC" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "'Const for this Application:" & vbCrLf
    s = s & "Private Const dc_Hwnd = 1" & vbCrLf
    s = s & "Private Const dc_ClassName = 2" & vbCrLf
    s = s & "Private Const dc_CtlID = 3" & vbCrLf
    s = s & "Private Const dc_CtlText = 4" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "Private Const Window_Search_Timeout As Single = 5#" & vbCrLf
    s = s & "Public ChildWindowsPropDict As Object" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "#If VBA7 Then" & vbCrLf
    s = s & "    Private Function GetCtlText(ByVal hctl As LongPtr) As String" & vbCrLf
    s = s & "#Else" & vbCrLf
    s = s & "    Private Function GetCtlText(ByVal hctl As Long) As String" & vbCrLf
    s = s & "#End If" & vbCrLf
    s = s & "    Dim ControlText As String" & vbCrLf
    s = s & " On Error GoTo WindowTextTooLarge" & vbCrLf
    s = s & "    ControlText = Space(GetWindowTextLength(hctl) + 1)" & vbCrLf
    s = s & "    GetWindowText hctl, ControlText, Len(ControlText)" & vbCrLf
    s = s & "    GetCtlText = ControlText 'Controls Text" & vbCrLf
    s = s & "    Exit Function" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "WindowTextTooLarge:" & vbCrLf
    s = s & "    ControlText = Space(256)" & vbCrLf
    s = s & "    On Error GoTo -1" & vbCrLf
    s = s & "    GetWindowText hctl, ControlText, Len(ControlText)" & vbCrLf
    s = s & "    GetCtlText = ControlText  'Controls Text" & vbCrLf
    s = s & "End Function" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "#If VBA7 Then" & vbCrLf
    s = s & "    Private Function EnumChildProc(ByVal hWnd As LongPtr, ByVal lParam As LongPtr) As Long" & vbCrLf
    s = s & "#Else" & vbCrLf
    s = s & "    Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long" & vbCrLf
    s = s & "#End If" & vbCrLf
    s = s & "    Dim ClassName As String" & vbCrLf
    s = s & "    Dim subCtlProp(1 To 4) As Variant" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    subCtlProp(dc_Hwnd) = hWnd 'Controls Handle" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    ClassName = Space(256)" & vbCrLf
    s = s & "    GetClassName hWnd, ClassName, Len(ClassName)" & vbCrLf
    s = s & "    subCtlProp(dc_ClassName) = Trim(CStr(ClassName)) 'Controls ClassName" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    subCtlProp(dc_CtlID) = GetWindowLongPtr(hWnd, GWL_ID) 'Controls ID" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    subCtlProp(dc_CtlText) = GetCtlText(hWnd)   'Controls Text 'Doesn't always work for some reason..." & vbCrLf
    s = s & "                                                '(sometimes returns """" when Spy++ finds a string)" & vbCrLf
    s = s & "    ChildWindowsPropDict.Add key:=CStr(hWnd), Item:=subCtlProp" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    'continue to enumerate (0 would stop it)" & vbCrLf
    s = s & "    EnumChildProc = 1" & vbCrLf
    s = s & "End Function" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "#If VBA7 Then" & vbCrLf
    s = s & "    Private Sub WriteChildWindowsPropDict(hWnd As LongPtr)" & vbCrLf
    s = s & "#Else" & vbCrLf
    s = s & "    Private Sub WriteChildWindowsPropDict(hWnd As Long)" & vbCrLf
    s = s & "#End If" & vbCrLf
    s = s & "    On Error Resume Next" & vbCrLf
    s = s & "    Set ChildWindowsPropDict = Nothing" & vbCrLf
    s = s & "    On Error GoTo 0" & vbCrLf
    s = s & "    Set ChildWindowsPropDict = CreateObject(""Scripting.Dictionary"")" & vbCrLf
    s = s & "    EnumChildWindows hWnd, AddressOf EnumChildProc, ByVal 0&" & vbCrLf
    s = s & "End Sub" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "Private Function ExistsFileInPath(ByVal FileName As String, ByVal FilePath As String, Optional warn As Boolean = False) As Boolean" & vbCrLf
    s = s & "    Dim oFso As Object" & vbCrLf
    s = s & "    Dim oFile As Object" & vbCrLf
    s = s & "    Dim oFolder As Object" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    Set oFso = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    s = s & "    'Setting the Folder of the Filepath" & vbCrLf
    s = s & "    On Error GoTo PathNotFound" & vbCrLf
    s = s & "    Set oFolder = oFso.GetFolder(Left(Replace(FilePath & ""\"", ""\\"", ""\""), Len(Replace(FilePath & ""\"", ""\\"", ""\"")) - 1))" & vbCrLf
    s = s & "    On Error GoTo 0" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    'Writing all Filenames of the Files in the Folder to flStr" & vbCrLf
    s = s & "    For Each oFile In oFolder.Files" & vbCrLf
    s = s & "        If oFile.Name = FileName Then" & vbCrLf
    s = s & "            ExistsFileInPath = True" & vbCrLf
    s = s & "            Exit Function" & vbCrLf
    s = s & "        End If" & vbCrLf
    s = s & "    Next oFile" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    ExistsFileInPath = False" & vbCrLf
    s = s & "    Exit Function" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "PathNotFound:" & vbCrLf
    s = s & "    If warn Then MsgBox ""The path "" & Chr(10) & FilePath & Chr(10) & "" was not found by the function ExistsFileInPath."" & Chr(10) & ""Returning FALSE""" & vbCrLf
    s = s & "    ExistsFileInPath = False" & vbCrLf
    s = s & "End Function" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "#If VBA7 Then" & vbCrLf
    s = s & "    Public Sub ScheduleSvgExportHelperProcess(ByVal Wb1hwnd As LongPtr, ByVal Wb1Name As String, ByVal SvgFileName As String, ByVal SvgFilePath As String)" & vbCrLf
    s = s & "#Else" & vbCrLf
    s = s & "    Public Sub ScheduleSvgExportHelperProcess(ByVal Wb1hwnd As Long, ByVal Wb1Name As String, ByVal SvgFileName As String, ByVal SvgFilePath As String)" & vbCrLf
    s = s & "#End If" & vbCrLf
    s = s & "    If Not Wb1hwnd = FindWindow(""XLMAIN"", Wb1Name & "" - Excel"") Then" & vbCrLf
    s = s & "        MsgBox ""Error finding Wb1hwnd - something unforseen happened!""" & vbCrLf
    s = s & "        GoTo badExit" & vbCrLf
    s = s & "    End If" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    Application.OnTime Now + TimeValue(""00:00:02""), ""'SvgExportHelperProcess """""" & CStr(Wb1hwnd) & """""", """""" & Wb1Name & """""", """""" & SvgFileName _" & vbCrLf
    s = s & "                        & """""", """""" & SvgFilePath & """"""'"", Now + TimeValue(""00:00:015"")" & vbCrLf
    s = s & "    Exit Sub" & vbCrLf
    s = s & "badExit:" & vbCrLf
    s = s & "    MsgBox ""Shutting down background instance of excel.""" & vbCrLf
    s = s & "    Application.DisplayAlerts = False" & vbCrLf
    s = s & "    Application.Quit" & vbCrLf
    s = s & "End Sub" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "Public Sub SvgExportHelperProcess(ByVal Wb1hwndStr As String, ByVal Wb1Name As String, ByVal SvgFileName As String, ByVal SvgFilePath As String)" & vbCrLf
    s = s & "    #If VBA7 And Win64 Then" & vbCrLf
    s = s & "        Dim Wb1hwnd As LongPtr" & vbCrLf
    s = s & "        Wb1hwnd = CLngPtr(Wb1hwndStr)" & vbCrLf
    s = s & "        Dim dlgHwnd As LongPtr" & vbCrLf
    s = s & "        Dim tempHctrl As LongPtr" & vbCrLf
    s = s & "    #Else" & vbCrLf
    s = s & "        Dim Wb1hwnd As LongPtr" & vbCrLf
    s = s & "        Wb1hwnd = CLng(Wb1hwndStr)" & vbCrLf
    s = s & "        Dim dlgHwnd As Long" & vbCrLf
    s = s & "        Dim tempHctrl As Long" & vbCrLf
    s = s & "    #End If" & vbCrLf
    s = s & "    Dim i As Long" & vbCrLf
    s = s & "    Dim stopTime As Single" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    'Find dialog window handle" & vbCrLf
    s = s & "    stopTime = Timer() + Window_Search_Timeout" & vbCrLf
    s = s & "    Do" & vbCrLf
    s = s & "        dlgHwnd = 0" & vbCrLf
    s = s & "        Sleep 15" & vbCrLf
    s = s & "        DoEvents" & vbCrLf
    s = s & "        SetForegroundWindow Wb1hwnd  'FindWindow(""XLMAIN"", Wb1Name & "" - Excel"")" & vbCrLf
    s = s & "        Sleep 150" & vbCrLf
    s = s & "        dlgHwnd = FindWindow(""#32770"", vbNullString)" & vbCrLf
    s = s & "    Loop Until Timer() > stopTime Or dlgHwnd <> 0" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    If dlgHwnd = 0 Then" & vbCrLf
    s = s & "        MsgBox ""Couldn't find dialog window handle!""" & vbCrLf
    s = s & "        GoTo errHand" & vbCrLf
    s = s & "    End If" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    'Enumerate the child windows of the dialog and write their properties to a dictionary" & vbCrLf
    s = s & "    WriteChildWindowsPropDict dlgHwnd" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "    'the first window of class ""Edit"" inside ChildWindowsPropDict will be the filename box" & vbCrLf
    s = s & "    Dim v As Variant" & vbCrLf
    s = s & "    For Each v In ChildWindowsPropDict.items" & vbCrLf
    s = s & "        If Left(CStr(v(dc_ClassName)), Len(CStr(v(dc_ClassName))) - 1) = ""Edit"" Then" & vbCrLf
    s = s & "            tempHctrl = v(dc_Hwnd)" & vbCrLf
    s = s & "            'send message" & vbCrLf
    s = s & "            SendMessage tempHctrl, WM_SETTEXT, 0&, ByVal SvgFilePath & ""\"" & SvgFileName" & vbCrLf
    s = s & "            'we don't need this hwnd anymore" & vbCrLf
    s = s & "            ChildWindowsPropDict.Remove CStr(v(dc_Hwnd))" & vbCrLf
    s = s & "            Exit For" & vbCrLf
    s = s & "        End If" & vbCrLf
    s = s & "    Next v" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "retry:" & vbCrLf
    s = s & "    SetForegroundWindow dlgHwnd" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    SendKeys ""{TAB}""" & vbCrLf
    s = s & "    Sleep 250" & vbCrLf
    s = s & "    SetForegroundWindow dlgHwnd" & vbCrLf
    s = s & "    For i = 1 To 10" & vbCrLf
    s = s & "        SendKeys ""{DOWN}""" & vbCrLf
    s = s & "        Sleep 100" & vbCrLf
    s = s & "        SetForegroundWindow dlgHwnd" & vbCrLf
    s = s & "    Next i" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    SendKeys ""~""" & vbCrLf
    s = s & "    Sleep 100" & vbCrLf
    s = s & "    SetForegroundWindow dlgHwnd" & vbCrLf
    s = s & "    SendKeys ""~""" & vbCrLf
    s = s & "    Sleep 50" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    'give the keystrokes time to process" & vbCrLf
    s = s & "    Sleep 300" & vbCrLf
    s = s & "" & vbCrLf
    s = s & "    'Wait until the file appears in the specified path:" & vbCrLf
    s = s & "    Dim cleanFileName As String" & vbCrLf
    s = s & "    If InStr(1, Right(SvgFileName, 4), "".svg"", vbTextCompare) = 0 Then" & vbCrLf
    s = s & "        cleanFileName = SvgFileName & "".svg""" & vbCrLf
    s = s & "    Else" & vbCrLf
    s = s & "        cleanFileName = SvgFileName" & vbCrLf
    s = s & "    End If" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    Dim retryTime As Single" & vbCrLf
    s = s & "    retryTime = Timer + 5" & vbCrLf
    s = s & "    stopTime = Timer + 60  '1 minute timeout." & vbCrLf
    s = s & "                            'relatively long in case a file already exists dialog appears..." & vbCrLf
    s = s & "    Do Until ExistsFileInPath(SvgFileName, SvgFilePath, False)" & vbCrLf
    s = s & "        Sleep 700" & vbCrLf
    s = s & "        DoEvents" & vbCrLf
    s = s & "        If Timer > retryTime Then" & vbCrLf
    s = s & "            'check if graphic export dialog is top window" & vbCrLf
    s = s & "            If dlgHwnd = GetForegroundWindow Then GoTo retry" & vbCrLf
    s = s & "        End If" & vbCrLf
    s = s & "        If Timer > stopTime Then GoTo timeoutHand" & vbCrLf
    s = s & "    Loop" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "    Exit Sub" & vbCrLf
    s = s & "errHand:" & vbCrLf
    s = s & "    MsgBox ""Error in the helper process""" & vbCrLf
    s = s & "    GoTo badExit" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "timeoutHand:" & vbCrLf
    s = s & "    MsgBox ""Timeout. It seems like something went wrong creating the file. File "" & cleanFileName & "" didn't appear in folder "" & SvgFilePath & "".""" & vbCrLf
    s = s & "    GoTo badExit" & vbCrLf
    s = s & "    " & vbCrLf
    s = s & "badExit:" & vbCrLf
    s = s & "    MsgBox ""Shutting down background instance of excel.""" & vbCrLf
    s = s & "    Application.DisplayAlerts = False" & vbCrLf
    s = s & "    Application.Quit" & vbCrLf
    s = s & "End Sub" & vbCrLf
    s = s & "" & vbCrLf
    CreateCodeForOtherXlInstance = s
End Function

Answer 3

如果您特别不需要 .svg，那么 .emf 是另一种矢量格式。它不能直接在 Excel 中运行，但可以使用“帮助”PowerPoint 应用程序运行：

Sub ExportChartToEMF(ByVal ch As Chart, ByVal filePath As String)
    Const methodName As String = "ExportChartToEMF"
    Const ppShapeFormatEMF As Long = 5
    '
    If ch Is Nothing Then Err.Raise 91, methodName, "Chart not set"
    '
    Dim pp As Object
    Dim slide As Object
    Dim errNumber As Long
    '
    Set pp = CreateObject("PowerPoint.Application")
    With pp.Presentations.Add(msoFalse) 'False so it's not Visible
        Set slide = .Slides.AddSlide(.Slides.Count + 1, .Designs(1).SlideMaster.CustomLayouts(1))
    End With
    '
    ch.Parent.Copy
    On Error Resume Next
    slide.Shapes.Paste.Export filePath, ppShapeFormatEMF
    errNumber = Err.Number
    On Error GoTo 0
    '
    pp.Quit
    If Err.Number <> 0 Then Err.Raise Err.Number, methodName, "Error while exporting to file"
End Sub

你会像这样使用它：

ExportChartToEMF ActiveChart, "[FolderPath]\[FileName].emf"

如果您确实需要 .svg，那么很遗憾，该功能并未向 VBA 公开，尽管它通过 另存为图片 对话框（右键单击图表形状）在 Excel 和 PowerPoint 中手动工作。 p>

简而言之，除非您通过中间格式（如 .emf 或 .pdf）或通过另存为图片 对话框。

Answer 4

以矢量格式导出：

如果您的主要问题是以某种矢量格式导出图表，我建议您只导出为 PDF，因为这非常简单：

Set curChart = objChrt.Chart
objChrt.ExportAsFixedFormat xlTypePDF, "YourChart"

PDF 现在包含作为矢量图形的图表，并且 PDF 是一种广泛支持的格式，可用于进一步处理。

如果您绝对需要将图表转换为 .svg，您可以从命令行（因此很容易实现自动化）使用开源软件 Inkscape 我认为： /。

转换为 SVG：

不幸的是，Inkscape 转换似乎对我不起作用，所以我使用开源 pdf 渲染工具包Poppler 实现了它。 （安装说明在本文底部）

该库提供命令行实用程序pdftocairo，将在以下解决方案中使用：

Sub ExportChartToSVG()
    Dim MyChart As ChartObject
    Set MyChart = Tabelle1.ChartObjects("Chart 1")
    
    Dim fileName As String
    fileName = "TestExport"

    Dim pathStr As String
    pathStr = ThisWorkbook.Path
    
    ' Export chart as .pdf
    MyChart.Chart.ExportAsFixedFormat Type:=xlTypePDF, FileName:=pathStr & "\" & fileName
   
    ' Convert .pdf file to .svg
    Dim ret As Double
    ret = Shell("cmd.exe /k cd /d """ & pathStr & """ & " & "pdftocairo -svg -f 1 -l 1 " & fileName & ".pdf", vbHide)
End Sub

请注意，生成的 .svg 文件中的文本不可选择，并且该文件大于手动导出生成的文件（我的测试中为 241 KB 与 88 KB）。该文件绝对是无限分辨率的，所以不是嵌入在 .svg 文件中的奇怪位图偶尔会看到，但会带来另一个小问题：

不幸的是，ExportAsFixedFormat 方法会创建一个 PDF“页面”，其中图形在页面上的位置取决于工作表上的位置。不幸的是，.svg 转换保留了这种“页面”格式。我必须明白，摆脱这个问题并不像我最初想象的那么简单，因为 excel 不支持自定义页面大小，因此将图表导出为没有白色边框的 .pdf 似乎几乎是不可能的，请参阅这个充满但未解决的 question （编辑：我在以下部分解决了它，并将我的方法发布为该问题的答案）。我尝试了几种他们在这个链接的问题中甚至没有想到的方法，但仍然无法仅使用 Excel 正确完成它，这可能取决于您的打印机驱动程序，但我不会那样做......

导出为没有白条的干净 SVG：

最简单的解决方法是仅使用 Word 将图表正确导出为 .pdf：

Sub ExportChartToSVG()
    Dim MyWorksheet As Worksheet
    Set MyWorksheet = Tabelle1
    
    Dim MyChart As ChartObject
    Set MyChart = MyWorksheet.ChartObjects(1)
    
    Dim fileName  As String
    fileName = "TestExport"
    
    Dim pathStr As String
    pathStr = ThisWorkbook.Path
    
    'Creating a new Word Document
    'this is necessary because Excel doesn't support custom pagesizes
    'when exporting as pdf and therefore unavoidably creates white borders around the
    'chart when exporting
    Dim wdApp As Object
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
    
    Dim wdDoc As Object
    Set wdDoc = wdApp.Documents.Add
    
    MyChart.Copy
    wdDoc.Range.Paste
    
    Dim shp As Object
    Set shp = wdDoc.Shapes(1)
    
    With wdDoc.PageSetup
        .LeftMargin = 0
        .RightMargin = 0
        .TopMargin = 0
        .BottomMargin = 0
        .PageWidth = shp.Width
        .PageHeight = shp.Height
    End With
    shp.Top = 0
    shp.Left = 0
    
    wdDoc.saveas2 fileName:=pathStr & "\" & fileName, FileFormat:=17  '(wdExportFormatPDF)
    wdApp.Quit 0 '(wdDoNotSaveChanges)
    Set wdApp = Nothing
    Set wdDoc = Nothing
    Set shp = Nothing

    ' Convert .pdf file to .svg
    Dim ret As Double
    ret = Shell("cmd.exe /k cd /d """ & pathStr & """ & " & "pdftocairo -svg -f 1 -l 1 " & fileName & ".pdf", vbHide)
End Sub

生成的 .pdf 和 .svg 看起来与手动导出的 .svg 完全相同，只有 .pdf 具有可选择的文本。 .pdf 文件保留在文件夹中。如有必要，稍后可以通过 VBA 代码轻松删除...

如果此方法用于导出大量图表，我强烈建议将其移到一个类中并让该类保存 Word 应用程序的一个实例，这样它就不会不断地重新打开和关闭 Word。它的额外好处是使导出的实际代码非常简洁明了。

导出为干净 SVG 的基于类的方法：

导出的代码变得非常简单：

Sub ExportChartToSVG()
    Dim MyWorksheet As Worksheet
    Set MyWorksheet = Tabelle1
    
    Dim MyChart As ChartObject
    Set MyChart = MyWorksheet.ChartObjects(1)
    
    Dim fileName  As String
    fileName = "TestExport"
    
    Dim filePath As String
    filePath = ThisWorkbook.Path
    
    Dim oShapeExporter As cShapeExporter
    Set oShapeExporter = New cShapeExporter
    
    ' Export as many shapes as you want here, before destroying oShapeExporter
    ' cShapeExporter can export objets of types Shape, ChartObject or ChartArea
    oShapeExporter.ExportShapeAsSVG MyChart, fileName, filePath

    Set oShapeExporter = Nothing
End Sub

名为 cShapeExporter 的类模块的代码：

Option Explicit

Dim wdApp As Object
Dim wdDoc As Object
Dim wdWasOpen As Boolean

Private Sub Class_Initialize()
    If WordIsRunning Then
        Set wdApp = GetObject(, "Word.Application")
        wdWasOpen = True
    Else
        Set wdApp = CreateObject("Word.Application")
        wdApp.Visible = False
        wdWasOpen = False
    End If
    
    Set wdDoc = wdApp.Documents.Add
    
    With wdDoc.PageSetup
        .LeftMargin = 0
        .RightMargin = 0
        .TopMargin = 0
        .BottomMargin = 0
    End With
End Sub

Private Sub Class_Terminate()
    If Not wdWasOpen Then
        wdApp.Quit 0 '(wdDoNotSaveChanges)
    Else
        wdDoc.Close 0
    End If
    Set wdApp = Nothing
    Set wdDoc = Nothing
End Sub

Public Sub ExportShapeAsSVG(xlShp As Object, fileName As String, filePath As String)
    If TypeName(xlShp) = "ChartObject" Or TypeName(xlShp) = "Shape" Or TypeName(xlShp) = "ChartArea" Then
        'fine
    Else
        MsgBox "Exporting Objects of type " & TypeName(xlShp) & " not supported, sorry."
        Exit Sub
    End If
    
    xlShp.Copy
    wdDoc.Range.Paste
    
    Dim wdShp As Object
    Set wdShp = wdDoc.Shapes(1)
    
    With wdDoc.PageSetup
        .PageWidth = wdShp.Width
        .PageHeight = wdShp.Height
    End With
    
    wdShp.Top = 0
    wdShp.Left = 0
    
    ' Export as .pdf
    wdDoc.saveas2 fileName:=filePath & "\" & fileName, FileFormat:=17  '(wdExportFormatPDF)
    
    ' Convert .pdf file to .svg
    Dim ret As Double
    ret = Shell("cmd.exe /k cd /d """ & filePath & """ & " & "pdftocairo -svg -f 1 -l 1 " & fileName & ".pdf", vbHide)
    
    ' Delete temporary shape in wdDoc
    wdShp.Delete
End Sub

Private Function WordIsRunning() As Boolean
    Dim wdApp As Object
    On Error Resume Next
    Err.Clear
    Set wdApp = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
        WordIsRunning = False
    Else
        WordIsRunning = True
    End If
End Function

安装 Poppler 实用程序：

我假设你在这里使用的是 Windows，在 Linux 上获取 Poppler 是微不足道的......

所以在 Windows 上，我建议使用 Windows 的 chocolatey 数据包管理器安装它。要安装 Chocolatey，您可以关注 these instructions（需要

当你有巧克力的时候，你可以用简单的命令安装 Poppler

choco install poppler

您已准备好运行我建议的将 .pdf 转换为 .svg 的代码。

如果您更喜欢以不同的方式安装 Poppler，here 描述了各种选项，但我想添加一些关于某些方法的说明：

1. 我无法下载二进制文件，运行该实用程序总是会导致错误。
2. 通过 Anaconda (conda install -c conda-forge poppler) 安装不知何故对我也不起作用。刚刚安装失败。
3. 通过适用于 Linux 的 Windows 子系统安装确实有效，该实用程序也有效，但如果您还没有安装包含发行版的 wsl，则必须下载并安装数百 MB 的 ob 数据，这可能有点过头了。
4. 如果您安装了 MiKTeX，则应该包含该实用程序（在我的情况下是）。我从 MiKTeX 安装中尝试了该实用程序，但不知何故它不起作用。