我正在尝试使用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"；(所以这与激活或可见性无关)。此外，建议的修复程序也不起作用。
以矢量格式导出：
如果你的主要问题是以某种矢量格式导出图表，我建议只导出为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似乎几乎是不可能的，看看这个丰富但尚未解决的问题(编辑：我在下面的部分解决了它，并发布了我的方法作为该问题的答案)。我尝试了几个他们在这个链接问题中甚至没有想到的方法，但仍然无法仅使用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的巧克力数据包管理器进行安装。要安装巧克力，您可以按照以下说明进行操作(需要<5分钟)。
当你有巧克力时，你可以用简单的命令安装Poppler
choco install poppler
您已经准备好运行我建议的将.pdf转换为.svg.的代码了
如果你喜欢以不同的方式安装Poppler，这里有各种选项，但我想添加一些关于其中一些方法的注释：
- 下载二进制文件对我来说不起作用，运行该实用程序总是会导致错误
- 通过Anaconda(
conda install -c conda-forge poppler)安装对我来说也不起作用。安装刚刚失败 - 通过Windows Subsystem for Linux进行安装确实有效，该实用程序也有效，但如果您还没有安装包括发行版在内的wsl，则必须下载并安装几百MB的ob数据，这可能有些过头了
- 如果您安装了MiKTeX，那么应该包括该实用程序(在我的情况下也是如此)。我从我的MiKTeX安装中尝试了这个实用程序，但不知怎么的，它不起作用
2023更新
这个问题似乎在Excel版本2302 Build 16.0.16130.20186)64位中得到了修复，它在2021年发布的一个版本中得到了解决。不幸的是，我在发行说明/档案中找不到关于此修复程序的提及。
这现在按照文档中的规定工作：
With ThisWorkbook.Worksheets("Sheet1")
.ChartObjects("Chart 1").Chart.Export FileName:="pathname.svg", _
FilterName:="SVG"
End With
为了将来参考，我将为下面的错误留下原始的解决方法。然而，即使您使用的是一个有缺陷的Excel版本，我也建议您使用Jeremy Lakeman的这种更优雅的解决方法。
旧解决方案
仅使用Excel和VBA导出到没有任何外部应用程序的.SVG
这是一个的混乱，但它是有效的。至少现在。。。
首先，我将解释它是如何工作的，存在哪些必须克服的问题，以及它们是如何解决的。如果您对技术细节不感兴趣，可以跳到简单使用指南一节。
有什么想法
该代码尝试仅使用手动导出方法。这有几个问题，第一个是Chart.Export方法中的另一个错误。Chart.Export Interactive:=True应该打开所需的对话框，但这根本不起作用。通过利用一些快捷方式，可以非常可靠地使用SendKeys "+{F10}"和SendKeys "g"打开导出窗口。第一个障碍已经克服，但麻烦才刚刚开始！
事实证明，打开一个模态对话框会停止整个应用程序中的所有代码执行。即使在打开对话框之前调用了另一个应用程序实例中的代码，我们如何保持它在那里运行，并返回以完成打开对话框？这听起来不可能，因为VBA是严格的单线程。。。
事实证明，单线程并没有那么严格。该解决方案被称为Application.OnTime，它在未来的预定时间开始一个过程。该过程必须在Excel.Application的另一个实例中运行，因为Application.OnTime只有在应用程序处于某些模式(就绪、复制、剪切或查找)时才会启动过程，并且运行VBA代码或打开模式对话框不在这些模式之列。因此，在打开对话框之前，需要创建Excel应用程序的后台实例，将VBA代码插入其中，并计划在对话框打开后开始在后台实例中运行。注意：由于代码是自动插入到后台实例中的，因此需要启用对VBA工程对象模型的信任访问。
现在如何仅使用VBA代码处理Windows对话框？我设法通过CCD_ 11获得了对话框的所有窗口和控制句柄；FileName"；组合框。由于这个输入框也接受路径，所以只剩下选择"的问题；。svg"；在FileFormat组合框中；保存"；按钮不幸的是，我没能避免在这里使用SendKeys。
使用Windows API函数更改组合框中的选择相对容易，但问题是实际让它注册更改。它在对话框中似乎发生了变化，但当点击"；保存"；它仍然保存为.png。我在Spy++中花了几个小时监视手动更改期间发送的消息，但我无法用VBA复制它们。因此，更改文件格式并按"保存"时，必须再次使用SendKeys。
SendKeys在该解决方案中使用非常谨慎，包括各种安全检查，并在每次使用前将目标窗口拉到前面，但如果在宏运行时与pc进行交互，则它永远不会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
要使代码工作，您必须首先：
- 信任对VBA工程对象模型的访问(有关原因，请参阅宏的详细描述)
- 创建一个类模块，将其重命名为"；CCD_ 17"；，并将以下代码粘贴到其中：
'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
将图表复制到剪贴板时，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:tempoutput.svg"
如果您不需要.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中手动工作。
简而言之，除非使用中间格式(如.emf或.pdf)或通过另存为图片对话框手动保存到.svg，否则无法完全自动将图表导出到.svg文件。