Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

VBA Code funktioniert nur mit F8
#1
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
Antwortento top
#2
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
Antwortento top
#3
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.
Antwortento top
#4
Hallöchen,

ändere die Reihenfolge. Kopiere erst nach Erstellung des Chart.
   \\\|///      Hoffe, geholfen zu haben.
   ( ô ô )      Grüße, André aus G in T  
 ooO-(_)-Ooo    (Excel 97-2016)
Antwortento top
#5
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 Angry Angry
Antwortento top
#6
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
'.....
________
Servus
Case
Antwortento top
#7
Hola,

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

Gruß,
steve1da
Antwortento top
#8
ES FUNKTIONIERT  19 19 19

Vielen Dank Case
Antwortento top
#9
Leider scheint es - wie Case bereits schrieb - ohne Activate nicht zu laufen:
https://berndplumhoff.gitbook.io/sulprob...ge2picture
Antwortento top
#10
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
   \\\|///      Hoffe, geholfen zu haben.
   ( ô ô )      Grüße, André aus G in T  
 ooO-(_)-Ooo    (Excel 97-2016)
Antwortento top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste