Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema Image
BildScreenshot zu Image Image-Seite mit Beispielarbeitsmappe aufrufen

Chart.Paste Problem


Betrifft: Chart.Paste Problem von: Sascha Dorn
Geschrieben am: 28.03.2018 11:14:25

Hallo Zusammen,

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

  

Betrifft: AW: Chart.Paste Problem von: Luschi
Geschrieben am: 28.03.2018 20:11:53

Hallo Sascha,

es fehlt ein Select Befehl, bis Excel 2013 ging es noch ohne. Ab Excel 2015 und 365 ist der Pflicht, sonst ist das jpg-Bild leer!
So sieht mein verwendeter Code aus:

von 'Nepumuk
Public Sub Screenshot_abspeichern()
    Dim objChartObject As ChartObject
    Application.ScreenUpdating = False
    Worksheets("Partner").Select
    ActiveSheet.Range("S3:AH27").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set objChartObject = ActiveSheet.ChartObjects.Add(0, 0, Range("S3:AH27").Width, Range("S3: _
AH27").Height)
    With objChartObject
       .Select 
        .Parent.Activate
        With .Chart
            .Paste
            .Export "G:\" & "Diagramm.jpg", "JPG"
        End With
        .Delete
    End With
    Application.ScreenUpdating = True
End Sub
Gruß von Luschi
aus klein-Paris


Beiträge aus dem Excel-Forum zum Thema "Chart.Paste Problem"