Excel VBA - Zellbereich als Bild speicher / Code geht nur sporadisch

[Allan Sche Sar]

Hallo ihr,

ich habe im Netz ein Code für mein Problem gefunden, mit dem ich einen Zellbereich als Bild speichern kann.
Das Ergebnis ist genau das, was ich mir vorstelle, aber wenn ich den Code ein zweites mal ausführe, dann erhalte ich nicht das Bild der einzelnen Shapes und Textfelder, sondern nur ein weißes Bild.
Der angelegte Bildrahmen ist dann leer/ weiß. Dies habe ich beim Testdurchlauf (Einzelschritte) gesehen, aber ich weiß nicht warum.

Daher hoffe ich, dass ihr mir weiter helfen könnt.

Hier nun der verwendete Code:

Sub als_Bild_speichern()

Dim objPict As Object
Dim objChrt As Chart
Dim rngImage As Range 'Größe des zu speichernden Bereichs'
Dim strFile As String

    Application.ScreenUpdating = False
    ActiveWindow.DisplayGridlines = False 'Gitternetz anzeigen'
    
    If MsgBox("Haben Sie alle notwendigen Anpassungen vorgenommen, sodass das Bild der Fehlerlandkarte nun" _
            & " erzeugt werden kann?", vbYesNo, "Bearbeitung abgeschlossen?") = vbNo Then
        MsgBox "Bild der Fehlerlandkarte wird nicht erzeugt." & vbNewLine & _
                "Bitte passen Sie zunächst die Fehlerlandkarte fertig an.", vbOKOnly, _
                "Bild nicht erzeugt"
        Exit Sub
    Else
        'Als JPEG abspeichern'
        On Error GoTo ErrExit
        With ActiveSheet
            Set rngImage = .Range("A1:K56") 'Bereich der für das Bild verwendet wird.'
            rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
            .PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
            Set objPict = .Shapes(.Shapes.Count)
            strFile = "F:\Test.jpg" 'Pfad und Dateiname für das Bild'
            objPict.Copy
            Set objChrt = .ChartObjects.Add(1, 1, objPict.Width + 8, objPict.Height + 8).Chart
            objChrt.Paste
            objChrt.Export strFile
            objChrt.Parent.Delete
            objPict.Delete
        End With
        ActiveWindow.DisplayGridlines = True
        Application.ScreenUpdating = True
        MsgBox "Das Bild wurde erfolgreich unter: " & vbNewLine & strFile & vbNewLine & _
        "abgespeichert." & vbNewLine & _
                "Sie können nun das Bild in die globale Fehlerlandkarte einpflegen.", vbOKOnly, _
                "Bild erfolgreicht gespeichert"
    End If
    Exit Sub
    
    
  
ErrExit:
    Set objPict = Nothing
    Set objChrt = Nothing
    Set rngImage = Nothing
    
    ActiveWindow.DisplayGridlines = True
    Application.ScreenUpdating = True
    MsgBox "Ein kritischer Systemfehler ist aufgetreten, weshalb das Bild nicht gespeichert werden kann." & vbNewLine & _
            "Bitte wenden Sie sich an den Programmierer dieses Tools.", vbOKOnly, "Systemfehler vorhanden"

End Sub

Der Originalcode stammt von: http://www.herber.de/forum/archiv/1..._oder_Bereich_mit_VBA_als_Bild_speichern.html und lautet:

Option Explicit

Sub Range_To_Image()
  Dim objPict As Object, objChrt As Chart
  Dim rngImage As Range, strFile As String
  
  On Error GoTo ErrExit
  
  With Sheets("Tabelle1") 'Tabellenname - Anpassen!'
    
    Set rngImage = .Range("A1:C20")
    
    rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    
    .PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
    
    Set objPict = .Shapes(.Shapes.Count)
    
    strFile = "E:\Temp\meinBild.gif" 'Pfad und Dateiname für das Bild'
    
    objPict.Copy
    
    Set objChrt = .ChartObjects.Add(1, 1, objPict.Width + 8, objPict.Height + 8).Chart
    
    objChrt.Paste
    objChrt.Export strFile
    objChrt.Parent.Delete
    objPict.Delete
    
  End With
  
  ErrExit:
  Set objPict = Nothing
  Set objChrt = Nothing
  Set rngImage = Nothing
End Sub

Mein Problem ist, dass dieser Code mir den Rahmen meines Hintergrundbildes weg lässt, weil er dieses nicht auswählt. Die anderen Codes, welche ich im Netz finde, machen dies leider, was zu einem nicht so schönen Ergebnis führt.