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
为了让代码正常运行,您必须先执行以下步骤:
- 信任访问VBA项目对象模型(原因详见宏的详细说明)
- 创建一个类模块,将其重命名为 "
cShapeExporter
",并将以下代码粘贴到其中:
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)
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
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
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
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
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")
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
Chart.Export
实现此功能。 - BigBen