我通读了关于同一问题的多个线程,但它们似乎都具有不同的解决方案,因此无法将其应用于我的代码。我还在“导出”部分的所有行之间使用Application.Wait (Time + TimeValue("00:00:01"))
和DoEvents
测试了代码。
当我使用F5运行代码时,将导出空白图片。当我使用F8逐步运行它时,将导出正确的图片。当我快速跳过F8时,它也不起作用。我试图找出不允许执行太快但失败的那一行。
编辑
在chartobj.Activate
之前添加chartobj.Chart.Paste
很有帮助!
Hint in a comment on this thread...
Sub ExportSingleImage()
'Plotplan Export Single Script v. 2.3
Dim sheet, zoom_coef, area, chartobj
Dim exportpath, prefix As String
Dim sView, rr As String
Dim xWs As Worksheet
Dim leadingzeros As Boolean
'Export Path (with trailing backslash)
exportpath = ActiveWorkbook.Worksheets("Config").Range("B2")
'Prefix
prefix = ""
'Tankstellennummern Länge
idnumber_max = 6
'Leading Zeros
leadingzeros = False
'Print Area
rr = "B2:AI38"
'------------------------------------------------------------------------------
'Nothing to configure after here
'------------------------------------------------------------------------------
'Ask if existing files should be overwritten
overwrite = MsgBox("Existierende Dateien überschreiben?", vbYesNoCancel)
If overwrite = vbCancel Then
Exit Sub
End If
Set xWs = ActiveWorkbook.ActiveSheet
'Error when the sheetname is longer than the allowed max
If Len(xWs.Name) > idnumber_max Then
prompt = "Bezeichnung zu lang: " & xWs.Name & " (Maximal " & idnumber_max & " Stellen.)"
MsgBox (prompt)
Exit Sub
End If
'Check if export folder exists. If not, create it.
If Dir(exportpath, vbDirectory) = "" Then
MkDir exportpath
End If
'Assemble full path with filename
If leadingzeros Then
exportpath = exportpath & prefix & Right("000000" & xWs.Range("AJ47").Value, idnumber_max) _
& " - " & xWs.Range("AJ43").Value & ".png"
Else
exportpath = exportpath & prefix & xWs.Range("AJ47").Value _
& " - " & xWs.Range("AJ43").Value & ".png"
End If
'Check if file already exists or "overwrite" had been selected by the user
If Dir(exportpath) = "" Or overwrite = vbYes Then
' -- EXPORT --
'Captures current window view
sView = ActiveWindow.View
'Sets the current view to normal so there are no "Page X" overlays on the image
ActiveWindow.View = xlNormalView
'Temporarily disable screen updating
Application.ScreenUpdating = False
'Selection Print Area
xWs.PageSetup.PrintArea = xWs.Range(rr).Resize(xWs.Range(rr).Rows.Count, xWs.Range(rr).Columns.Count).Address
'Export print area as correctly scaled PNG image, courtasy of Winand
'Lukasz: zoom_coef can be constant = 0 to 5 can work too, but save is 0 to 4
zoom_coef = 2 '100 / sheet.Parent.Windows(1).Zoom
Set area = xWs.Range(xWs.PageSetup.PrintArea)
area.CopyPicture xlPrinter 'xlBitmap
Set chartobj = xWs.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export exportpath, "png"
chartobj.Delete
'Returns to the previous view
ActiveWindow.View = sView
'Re-enables screen updating
Application.ScreenUpdating = True
End If
End Sub