编程不是我的主要工作职能，但似乎是我所认为的瑞士军刀，我的任务是在 Excel 中制作一个 VBA 宏，将图形导出到 gif 文件，以便自动更新我们制造工厂的信息屏幕。
我有一个可以工作的宏，但是，它有时会失败并创建一个具有正确文件名但“空”图形的 gif。
用户在工作表的范围内定义自己的导出路径以及导出图表的尺寸。
Sub ExportAllCharts()
Application.ScreenUpdating = False
Const sSlash$ = "\"
Const sPicType$ = "gif"
Dim sChartName As String
Dim sPath As String
Dim sExportFile As String
Dim ws As Worksheet
Dim wb As Workbook
Dim chrt As ChartObject
Dim StdXAxis As Double
Dim StdYAxis As Double
Dim ActXAxis As Double
Dim ActYAxis As Double
Dim SheetShowPct As Double
Set wb = ActiveWorkbook
Set ws = ActiveSheet
StdXAxis = Range("StdXAxis").Value
StdYAxis = Range("StdYAxis").Value
sPath = Range("ExportPath").Value
If sPath = "" Then sPath = ActiveWorkbook.Path
For Each ws In wb.Worksheets 'check all worksheets in the workbook
If ws.Name = "Graphs for Export" Then
SheetShowPct = ws.Application.ActiveWindow.Zoom
For Each chrt In ws.ChartObjects 'check all charts in the current worksheet
ActXAxis = chrt.Width
ActYAxis = chrt.Height
With chrt
If StdXAxis > 0 Then .Width = StdXAxis
If StdYAxis > 0 Then .Height = StdYAxis
End With
sChartName = chrt.Name
sExportFile = sPath & sSlash & sChartName & "." & sPicType
On Error GoTo SaveError:
chrt.Chart.Export Filename:=sExportFile, FilterName:=sPicType
On Error GoTo 0
With chrt
.Width = ActXAxis
.Height = ActYAxis
End With
Next chrt
ws.Application.ActiveWindow.Zoom = SheetShowPct
End If
Next ws
Application.ScreenUpdating = True
MsgBox ("Export Complete")
GoTo EndSub:
SaveError:
MsgBox ("Check access rights for saving at this location: " & sPath & Chr(10) & Chr(13) & "Macro Terminating")
EndSub:
End Sub
收到帮助后，这是我最终放入工作簿中的宏代码：
谢谢您的帮助。
Const sPicType$ = "gif"
Sub ExportAllCharts()
Application.ScreenUpdating = False
Dim sChartName As String, sPath As String, sExportFile As String
Dim ws As Worksheet
Dim wb As Workbook
Dim chrt As ChartObject
Dim StdXAxis As Double, StdYAxis As Double, ActXAxis As Double
Dim ActYAxis As Double, SheetShowPct As Double
Set wb = ActiveWorkbook
StdXAxis = Range("StdXAxis").Value
StdYAxis = Range("StdYAxis").Value
sPath = Range("ExportPath").Value
If sPath = "" Then sPath = ActiveWorkbook.Path
Set ws = wb.Sheets("Graphs for Export")
For Each chrt In ws.ChartObjects
With chrt
ActXAxis = .Width
ActYAxis = .Height
If StdXAxis > 0 Then .Width = StdXAxis
If StdYAxis > 0 Then .Height = StdYAxis
sExportFile = sPath & "\" & .Name & "." & sPicType
.Select
.Chart.Export Filename:=sExportFile, FilterName:=sPicType
.Width = ActXAxis
.Height = ActYAxis
End With
Next chrt
Application.ScreenUpdating = True
MsgBox ("Export Complete")
End Sub
两件事情
1) 删除“出错时继续下一步”。否则你怎么知道路径是否正确？
2）为什么不循环遍历图表对象而不是循环遍历形状？例如
Dim chrt As ChartObject
For Each chrt In Sheet1.ChartObjects
Debug.Print chrt.Name
chrt.Chart.Export Filename:=sExportFile, FilterName:=sPicType
Next
FOLLOWUP
尝试这个。
Const sPicType$ = "gif"
Sub ExportAllCharts()
Application.ScreenUpdating = False
Dim sChartName As String, sPath As String, sExportFile As String
Dim ws As Worksheet
Dim wb As Workbook
Dim chrt As ChartObject
Dim StdXAxis As Double, StdYAxis As Double, ActXAxis As Double
Dim ActYAxis As Double, SheetShowPct As Double
Set wb = ActiveWorkbook
StdXAxis = Range("StdXAxis").Value
StdYAxis = Range("StdYAxis").Value
sPath = Range("ExportPath").Value
If sPath = "" Then sPath = ActiveWorkbook.Path
Set ws = wb.Sheets("Graphs for Export")
For Each chrt In ws.ChartObjects
ActXAxis = chrt.Width
ActYAxis = chrt.Height
With chrt
If StdXAxis > 0 Then .Width = StdXAxis
If StdYAxis > 0 Then .Height = StdYAxis
sChartName = .Name
sExportFile = sPath & "\" & sChartName & "." & sPicType
.Select
.Chart.Export Filename:=sExportFile, FilterName:=sPicType
.Width = ActXAxis
.Height = ActYAxis
End With
Next chrt
MsgBox ("Export Complete")
Exit Sub
SaveError:
MsgBox ("Check access rights for saving at this location: " & sPath & _
Chr(10) & Chr(13) & "Macro Terminating")
End Sub
本文内容由网友自发贡献，版权归原作者所有，本站不承担相应法律责任。如您发现有涉嫌抄袭侵权的内容，请联系:hwhale#tublm.com(使用前将#替换为@)
