Chart.Paste Problem
28.03.2018 11:14:25
Sascha
ich bin leider schon etwas am verzweifeln, ich habe ein Programm, dass mir aus einem Tabellenbereich ein Bild exportiert. Leider funktioniert das Programm nur wenn ich über den Paste Befehl mit einem Breakpoint und anschließend F8 druchlaufe. Sobald ich alles mit F5 durchlaufe funktioniert es nicht.
Hier mein Programm:
' Diese Funktion exportiert eine Tabelle in Form eines Bildes.
' Dazu wird die Tabelle in ein Diagramm kopiert um es zu exportieren, deses Diagramm wird
' nach dem Export sofort wieder gelöscht.
' Es lassen sich Parameter wie der Name den die Grafik beim Export erhalten soll und
' das Format (png, jpg, gif) übergeben.
' Ausgewählt wird die Tabelle mit Hilfe des Tabellennames und des
' Tabellenblattnames in der sich die Tabelle befindet.
Sub RangeToImage(path, wsheet, pvtab, picName)
Dim objPict As Object, objChrt As Chart
Dim rngImage As Range, strFile As String
Worksheets(wsheet).Activate
' auslesen des Tabellenbereichs
tabRange = Sheets(wsheet).PivotTables(pvtab).TableRange2.Address
' Tabellenbereich in obere linke Ecke und rechte untere Ecke aufspalten
pos = InStr(1, tabRange, ":")
tabStart = Left(tabRange, pos - 1)
tabEnd = Right(tabRange, Len(tabRange) - pos)
' ausgelesene Tabellenbereiche in Zeilen und Spalten trennen
pos = InStr(2, tabStart, "$")
tabStartCol = Right(Left(tabStart, pos - 1), Len(Left(tabStart, pos - 1)) - 1)
tabStartRow = Right(tabStart, Len(tabStart) - pos) ' + 1
pos = InStr(2, tabEnd, "$")
tabEndCol = Right(Left(tabEnd, pos - 1), Len(Left(tabEnd, pos - 1)) - 1)
tabEndRow = Right(tabEnd, Len(tabEnd) - pos)
If pvtab = "Pivot_NF_Auslauf" Then tabStartRow = tabStartRow + 1
' Tabellenbereich in benötigter Form zusammenführen
tabRange = tabStartCol & tabStartRow & ":" & tabEndCol & tabEndRow
Sheets(wsheet).Range(tabRange).Select
On Error GoTo ErrExit
app True
' Application.Wait (Now + TimeValue("00:00:10"))
With Sheets(wsheet) 'Tabellenname - Anpassen!
Set rngImage = .Range(tabRange)
rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
Set objPict = .Shapes(.Shapes.Count)
picName = Replace(picName, "/", "_")
strFile = path & picName & ".png" 'Pfad und Dateiname für das Bild
objPict.Copy
' Tabelle in Grafik kopieren um zu exportieren, Grafik anschliesend löschen
' original Grafik bleibt bestehen!
Set objChrt = .ChartObjects.Add(1, 1, objPict.Width + 0, objPict.Height + 0).Chart
objChrt.Paste ' #### HIER BREAKPOINT UND F8 ####
objChrt.Export strFile
objChrt.Parent.Delete
objPict.Delete
End With
ErrExit:
Set objPict = Nothing
Set objChrt = Nothing
Set rngImage = Nothing
app False
End Sub
Function app(status As Boolean)
If status = True Then status1 = xlAutomatic Else status1 = xlManual
Application.EnableEvents = status
Application.ScreenUpdating = status
Application.DisplayAlerts = status
Application.Calculation = status1
End Function