Clever-Excel-Forum

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 Sad

Vielleicht weiß einer von euch wo das Problem liegt Smile

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

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

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.

Hallöchen,

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

Guten Morgen schauan,

hat leider auch nicht funktioniert Sad

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 Angry

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

'.....

Hola,

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

Gruß,
steve1da

ES FUNKTIONIERT :19: :19: :19:

Vielen Dank Case

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

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

StevenB

volti

StevenB

schauan

StevenB

Case

steve1da

StevenB

Sulprobil

schauan