VBA Code funktioniert nur mit F8

[StevenB]

Hallöle alle zusammen,

ich habe das Problem, dass mein Code nur den gewünschten Effekt hat wenn ich ihn in Einzelschritten durchgehe.

Ziel ist es mehrere Zellbereiche als einzelne Bilder zu speichern und wenn ich den Code komplett laufen lasse sind meine Bilder leer

Vielleicht weiß einer von euch wo das Problem liegt

Habe auch schon an diversen Stellen versucht eine Pause einzubinden, jedoch hat das nicht geholfen.



Sub BildSave()

STATISTIK2.Cells(1, 1).Select

Range_To_Image "KERAPIC", "KERA"
Range_To_Image "HKKPIC", "HKK"
Range_To_Image "MIKAPIC", "MIKA"
Range_To_Image "DUESENPIC", "DUESEN"
Range_To_Image "DH500PIC", "DH500"

End Sub

Sub Range_To_Image(ByVal Bereich As String, BildName As String)
  Dim objPict As Object, objChrt As Chart
  Dim rngImage As Range, strFile As String

   
  On Error GoTo ErrExit
 
  With STATISTIK2 'Tabellenname - Anpassen!

    Set rngImage = .Range(Bereich)
    rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
   
    .PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
   
    Set objPict = .Shapes(.Shapes.Count)
   
    strFile = "c:\Laufwerk_D\AK\POWERPOINT\" & BildName & ".jpg" 'Pfad und Dateiname für das Bild
   
    objPict.Copy
   
    Set objChrt = .ChartObjects.Add(1, 1, objPict.Width, objPict.Height).Chart
   
    objChrt.Paste
    objChrt.Export strFile
    objChrt.Parent.Delete
    objPict.Delete
   
  End With
 
ErrExit:
  Set objPict = Nothing
  Set objChrt = Nothing
  Set rngImage = Nothing
 
  STATISTIK2.Cells(1, 1).Select
 
 
End Sub

[volti]

Hallo Steven,

versuch doch mal, ob folgender Code zum Erfolg führt. Der i-Zähler ist nur zur Sicherheit drin, damit es keine Endlosschleife wird.

Code:

Set rngImage = .Range(Bereich)
On Error Resume Next
i = 0
Do
  rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
  If Err.Number = 0 Then Exit Do
  Err.Clear
  i = i + 1: If i > 50 Then Exit Do
Loop
On Error GoTo 0

____________________
viele Grüße aus Freigericht
Karl-Heinz

[StevenB]

Vorab danke für den ersten Tipp, jedoch auch leider erfolglos.

Mittlerweile konnte ich herausfinden, dass das Problem scheinbar zwischen den Schritten

objPict.Copy
   
Set objChrt = .ChartObjects.Add(1, 1, objPict.Width, objPict.Height).Chart
   
objChrt.Paste


liegt.

[schauan]

Hallöchen,

ändere die Reihenfolge. Kopiere erst nach Erstellung des Chart.

[StevenB]

Guten Morgen schauan,

hat leider auch nicht funktioniert

    Set objChrt = .ChartObjects.Add(1, 1, objPict.Width, objPict.Height).Chart
   
    objPict.Copy
   
    objChrt.Paste


Wenn ich bei dem letzten Schritt einen Haltepunkt setze und dann jedes mal mit F5 weiterlaufen lasse geht es, dann sind meine Bilder nicht "leer". Ich raff echt nicht woran das liegen kann 

[Case]

Hallo, :19:

in neueren Excelversionen muss das Chart bzw. die Chartarea aktiviert/selektiert werden, sonst bleibt sie leer: :21:

Code:

'.....
    Set objChrt = .ChartObjects.Add(1, 1, objPict.Width, objPict.Height).Chart
    objChrt.Parent.Activate
    objChrt.Paste
    objChrt.Export strFile
    objChrt.Parent.Delete
    objPict.Delete
'.....

[steve1da]

Hola,

geht nochmal von vorne los.
http://www.office-loesung.de/p/viewtopic.php?f=166&t=849383

Gruß,
steve1da

[StevenB]

ES FUNKTIONIERT  :19: :19: :19:

Vielen Dank Case

[Sulprobil]

Leider scheint es - wie Case bereits schrieb - ohne Activate nicht zu laufen:
https://berndplumhoff.gitbook.io/sulprob...ge2picture

[schauan]

Hallöchen,

ohne Activate geht es, wenn man auf ein vorhandenes Chart zugreift statt ein neues zu erzeugen. Selbiges könnte dann auf einem zusätzlichen, gerne auch ausgeblendetem Blatt stehen.

Code:

Sub BildSave()

Range_To_Image "A1:C3", "Test"

End Sub

Sub Range_To_Image(ByVal Bereich As String, BildName As String)
  Dim objPict As Object, objChrt As ChartObject
  Dim rngImage As Range, strFile As String
  'On Error GoTo ErrExit

  With Sheets("Tabelle1") 'Tabellenname - Anpassen!
    Set rngImage = .Range(Bereich)
    rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    .PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
    Set objPict = .Shapes(.Shapes.Count)
    objPict.Copy
    strFile = "c:\Test\" & BildName & ".jpg" 'Pfad und Dateiname für das Bild
    Set objChrt = .ChartObjects(1)
    'oder mit zusaetzlichem Blatt:    Set objChrt = Sheets("TempDia").ChartObjects(1)

  With objChrt
      .Height = objPict.Height
      .Width = objPict.Width
      .Chart.Paste
      .Chart.Export strFile
      'Bild aus Chart entfernen, sicherheitshalber mit Schleife :-)
      Do While .Chart.Shapes.Count > 0
        .Chart.Shapes(1).Delete
      Loop
    End With
    objPict.Delete
    .Range("A1").Select
  End With

ErrExit:
  Set objPict = Nothing
  Set objChrt = Nothing
  Set rngImage = Nothing

End Sub