logo标签列表

将Excel图表导出为SVG创建了一个空文件。

excelvbachartsexport
6

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

    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过滤器被命名为任何其他名称。
有没有办法使用VBA以SVG格式导出图表呢？
注意：有另一个关于Chart.export生成空文件的问题，解决方法是在导出之前使用ChartObject.Activate。这个问题不同，因为使用“PNG”代码可以正确工作，但使用“SVG”会失败（因此与激活或可见性相关的问题）。此外，推荐的解决方法不起作用。
1
宏录制器是否有帮助 - 如果您手动导出，它会生成什么代码？ - BigBen
@BigBen 这个尝试是值得的，但遗憾的是，唯一记录的是“ActiveSheet.ChartObjects("Graphique 11").Activate”。 - Sylverdrag
2
经过一些测试/研究，我怀疑目前无法直接使用 Chart.Export 实现此功能。 - BigBen
导出为png并将文件重命名为SVG？？这样可以生成一个至少可以在mspaint中打开的图像... - Foxfire And Burns And Burns
1
@FoxfireAndBurnsAndBurns，问题在于这不会创建一个真正的 .svg 矢量图形... .svgs 可以包含嵌入的 .png 文件，我想你描述的情况基本上就是这样。 - GWD
4个回答
4

矢量格式导出：

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

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

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

如果您绝对需要将图表转换为.svg格式，则可以通过命令行（因此易于自动化）进行转换，或者我曾这样认为 :/。

转换为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 看起来几乎不可能，参见这个赏金未解决的问题。（编辑：我在下面的部分中解决了它，并将我的方法发布为答案）。我尝试了几种方法，甚至没有在链接的问题中想过的方法，仍然无法仅使用 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 & Application.PathSeparator
    
    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.ExportShapeAsPDF MyChart, filePath, fileName

    Set oShapeExporter = Nothing
End Sub

一个名为 cShapeExporter 的类模块的代码：

Option Explicit

Dim wdApp As Object
Dim wdDoc As Object

Private Sub Class_Initialize()
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False

    Set wdDoc = wdApp.Documents.Add
    
    ' Setting margins to 0 so we have no white borders!
    ' If you want, you can set custom white borders for the exported PDF here
    With wdDoc.PageSetup
        .LeftMargin = 0
        .RightMargin = 0
        .TopMargin = 0
        .BottomMargin = 0
    End With
End Sub

Private Sub Class_Terminate()
    ' Important: Close Word instance as the object is destroyed.
    wdApp.Quit 0 '(0 = wdDoNotSaveChanges)
    Set wdApp = Nothing
    Set wdDoc = Nothing
End Sub

Public Sub ExportShapeAsPDF(xlShp As Object, _
                            filePath As String, _
             Optional ByVal fileName As String = "")
    ' Defining which objects can be exported, maybe others are also supported,
    ' they just need to support all the methods and have all the properties used
    ' in this sub
    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 '(17 = wdExportFormatPDF)

    wdShp.Delete
End Sub

安装Poppler实用程序:

我假设你正在使用Windows，但在Linux上获取Poppler也很简单...

因此，在Windows上，我建议使用适用于Windows的chocolatey软件包管理器进行安装。要安装chocolatey，您可以按照这些说明进行操作（需要<5分钟）。

当您拥有了chocolatey之后，只需输入简单的命令即可安装Poppler。

choco install poppler

你已准备好运行我提供的将.pdf转换为.svg的代码。

如果你希望以不同的方式安装Poppler，有多种选项可以在这里找到，但我想添加一些关于某些方法的注释：

  1. 对我而言，下载二进制文件无法正常工作，使用此实用程序始终会导致错误。
  2. 通过Anaconda安装（conda install -c conda-forge poppler）也无法正常工作。安装失败了。
  3. 通过Windows子系统 for Linux进行安装可以正常工作，并且实用程序也可以正常工作，但是如果您尚未安装包括发行版在内的wsl，则必须下载并安装数百MB的数据，这可能有些过度。
  4. 如果您安装了MiKTeX，则应该包含此实用程序（在我的情况下是这样）。我尝试从我的MiKTeX安装中使用实用程序，但不知何故它无法正常工作。
4

2023 更新

这个问题似乎在Excel 版本 2302 Build 16.0.16130.20186 (64 位)中已经修复，它是在自 2021 年以来发布的某个版本中修复的。不幸的是，我在发行说明/存档中找不到对此修复的提及。

现在，它已按照文档所述正常工作：

With ThisWorkbook.Worksheets("Sheet1")
    .ChartObjects("Chart 1").Chart.Export FileName:="path\name.svg", _
                                          FilterName:="SVG"
End With

为了以后的参考，我将保留下面这个漏洞的原始解决方法。然而，即使您正在使用其中一个有缺陷的 Excel 版本，我建议改用Jeremy Lakeman提供的更加优雅的解决方法。

旧的解决方法

仅使用Excel和VBA导出.SVG文件而无需任何外部应用程序

这是一个hacky的混乱，但它有效。至少目前是这样...

首先我将解释它是如何工作的，存在哪些问题必须克服以及它们是如何解决的。如果您对技术细节不感兴趣，可以跳到简单使用指南部分。

想法是什么？

代码尝试只使用手动导出方法。这种方法存在几个问题，首先是Chart.Export方法中另一个错误。Chart.Export Interactive:=True应该打开所需的对话框，但这并不起作用。通过利用一些快捷方式，可以非常可靠地使用SendKeys "+{F10}"，然后使用SendKeys "g"来打开导出窗口。第一个障碍被克服了，但麻烦才刚刚开始！

原来，在应用程序中打开模态对话框会停止整个应用程序的所有代码执行。即使在我们打开对话框之前调用另一个应用程序实例中的代码，我们如何才能保持其在那里继续运行并返回以完成打开对话框呢？这听起来似乎是不可能的，因为VBA是严格单线程的...
原来单线程并不是那么严格。解决方案被称为 Application.OnTime，它可以在未来的某个预定时间启动一个过程。该过程必须在另一个 Excel.Application 实例中运行，因为只有当应用程序处于某些模式（Ready、Copy、Cut 或 Find）时，Application.OnTime 才会启动一个过程，而运行 VBA 代码或打开模态对话框并不在其中。因此，在打开对话框之前，需要创建一个 Excel 应用程序的后台实例，并将 VBA 代码插入其中，并安排在后台实例中打开对话框后开始运行。注意：由于代码自动插入到后台实例中，因此需要启用 信任对 VBA 项目对象模型的访问。

我们如何只使用VBA代码与Windows对话框进行交互？我通过EnumChildWindows获取了对话框的所有窗口和控件句柄，并使用这些信息将文本插入到“文件名”组合框中。由于此输入框还接受路径，因此仅剩下选择“ .svg”文件格式组合框并单击“保存”按钮的问题。不幸的是，我在这里无法避免使用SendKeys。

使用Windows API函数更改组合框中的选择相对容易，但问题在于实际上要使其注册更改。它似乎在对话框中发生了变化，但单击“保存”时仍会保存为.png。我花了几个小时在Spy++中监视手动更改期间发送的消息，但我无法使用VBA重现它们。因此，必须再次使用SendKeys来更改文件格式并按下“保存”。

SendKeys在此解决方案中非常谨慎地使用，包括各种安全检查和在每次使用前将目标窗口拉到前面，但如果在运行宏时与计算机交互，则永远不会100％安全。

由于该方法需要类似于here和here的应用程序的后台实例，因此我实现了一个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. 信任访问VBA项目对象模型（原因详见宏的详细说明）
  2. 创建一个类模块，将其重命名为 "cShapeExporter"，并将以下代码粘贴到其中：
'Class for automatic exporting in SVG-Format
'Initial author: Guido Witt-Dörring, 09.12.2020
'https://dev59.com/rr7pa4cB1Zd3GeqPy3OU#65212838

'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
1
哇，这太厉害了。我从来不知道你可以在 VBA 中做到这一点。 - Sylverdrag
1
当你复制一个图表时，Excel会将“image/svg+xml”类型添加到剪贴板中。我还没有尝试过，但导出这种格式感觉不那么hacky。 - Jeremy Lakeman
我现在已经尝试过了，请查看答案（目前在下面...） - Jeremy Lakeman
2
当您将图表复制到剪贴板时，Excel会添加许多不同的剪贴板格式。自2011版本（Application.Build >= 13426）以来，这现在包括“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 = CLng(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"
这是一个很好的解决方案！在64位版本的Excel中运行它时，我遇到了“类型不匹配”编译错误，因为GlobalSize(data)返回LngPtr而length声明为long。将该行更改为length = CLng(GlobalSize(data))修复了问题，并且它完美地工作了。这确实比我的想法更少hacky... - GWD
2
如果您不需要特别使用.svg格式，那么.emf是另一种矢量格式。它不能直接从Excel中使用，但可以使用一个名为“helper”的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 中可以通过“另存为图片”对话框（右键单击图表形状）手动工作。

简而言之，除非你通过中间格式（如 .emf 或 .pdf），或者通过“另存为图片”对话框手动保存为 .svg，否则无法完全自动化地将图表导出为 .svg 文件。

网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接