VBA Schleife Bilder aus Excel exportieren

[snb]

Verwende IrfanView

Code:

Sub M_snb()
  c00 = Mid(Environ(18), 14) & "\Irfanview\"
  c01=  Dir(c00 & "i_view*.exe")

  For Each it In Tabelle1.Shapes
    it.Copy
    Shell c00 & c01 & " /clippaste /convert=G:\OF\" & it.Name & ".png", 0
  Next
End Sub

[knobbi38]

@snb

Code:

...
    it.Copy
...

müßte nicht anstatt .copy die Methode .copypicture verwendet werden?

Grüße
Ulrich

[schauan]

... it ist ggf. schon ein Bild irfanview hat eventuell nicht jeder, mit paint ist's nicht ganz so einfach

[snb]

@knob

Hier läuft's mit copy, aber mit .copypicture (getestet) auch.

[schauan]

Hallöchen,

hier mal noch mein code. Dabei ist zu beachten, dass das Blatt mit dem Diagramm bzw. Excel nicht minimiert und das Screenupdating nicht deaktiviert ist, ansonsten gibt's ein weißes Bild ...
In der Schleife ueber alle Bilder müsste der Dateiname noch variabel gestaltet werden, z.B. mit einem Index anhand der Schleifendurchläufe, ansonsten siehe Kommentar
Eventuell vorhandene Bilder gleichen Namens werden ohne Vorwarnung überschrieben.
Aus dem Bereich Zeilen 90 bis 220 würden sicher auch die Zeilen 100-120 reichen. Ich hatte da mal Probleme in einem Projekt ...
Wenn Du nix scalieren willst, kann auch der ratio-Part entfallen.

Code:

Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub SavePict()
  For Each pict In Tabelle1.Shapes
    pict.Copy
    GraphicsExport pict, pict.Name, "jpg", 1
  Next
End Sub

'-----------------------------------------------------------------
'--- Zwischenablage leeren ---
'-----------------------------------------------------------------
Sub ClearClipboard()
    OpenClipboard 0&
    EmptyClipboard
    CloseClipboard
End Sub

'-----------------------------------------------------------------
'--- Bild exportieren ---
'-----------------------------------------------------------------

Function GraphicsExport(ByVal pict As Shape, ByVal PictName As String, ByVal PictType As String, ByVal PictRatio As Double)
          Dim tempDia As Chart, tempSheet As Worksheet, shPict As Shape, t
          Const TIMEOUT = 0.5 ' Seconds between repeating of CopyPicture
          Const ATTEMPTS = 10 ' Attempts of CopyPicture repeating

30       PictName = PictName + "." + PictType

          'Bild des Bereiches kopieren und erstmal temp. ablegen,
          'Screenupdate auf wahr und Windowstat auf normal setzen, sonst ist der Bildbereich weiß
50        Application.ScreenUpdating = True
          ActiveWindow.WindowState = xlNormal
          'Blatt mit Diagramm erstellen
60        Set tempSheet = ActiveSheet
          'Diagramm setzten
70        Set tempDia = tempSheet.Shapes.AddChart.Chart
          'Schleife ueber alle Bilder - ist so eigentlich falsch, muesste anders organisiert werden !!!
          'ansonsten wird die Bilddatei bei jedem Bild ueberschrieben.
80        For Each shPict In Tabelle1.Shapes
            'sicher gehen, dass das Kopieren geklappt hat
90          For icnt = 1 To ATTEMPTS
100           Application.CutCopyMode = False: ClearClipboard
110           DoEvents
120           shPict.Copy
130           If Err Then
140             Err.Clear
150             t = Timer + TIMEOUT
160             While Timer < t
170               DoEvents
180             Wend
190           Else
200             Exit For
210           End If
220         Next
            'kurz beruhigen lassen
230         Sleep 500
            'und nun das Diagramm anpassen
240         With tempDia
250           .Parent.Height = pict.Height + 1
260           .Parent.Width = pict.Width + 1
270           .Paste
280           DoEvents
330           .Parent.Height = .Parent.Height * PictRatio
340           .Parent.Width = .Parent.Width * PictRatio
350           .Export "C:\Test\" & PictName, PictType, False
360         Sleep 500
370           .ChartArea.Clear 'Bild im Diagramm loeschen
300         End With
390       Next
400       Application.ScreenUpdating = False 'brauchen wir eigentlich hier nicht
410       tempSheet.Shapes(tempDia.Parent.Name).Delete 'Diagramm loeschen
420       Set tempDia = Nothing
430       Application.CutCopyMode = False: ClearClipboard
End Function

[Raisix]

Hallo und herzlichen Dank für die tolle und schnelle Hilfe von euch allen. Ich bin euch sehr dankbar dafür.

Ich habe die Lösungen getestet. Bislang komme ich nicht zu dem gewünschten Ergebnis.
Bitte nicht lachen: zu Hause habe leider nur 2007. Morgen kann ich es auf 2016 bzw. 2019 testen. Ich kann gerade nicht abschätzen, ob deswegen einige Lösungsansätze bei mir nicht funktionieren. Zumindest #15 kann ich vermutlich daher gerade nicht umsetzen.

Zur Frage aus Antwort #5:
Die Bilder (QR-Codes) werden händisch eingefügt.

Hinweis zur Antwort #6:
"Die zu exportierenden Bilder folgen genau dem bereits beschriebenen Muster:
Bild 1 aus Bereich B1:C2
Bild 2 aus Bereich B4:C5
usw.
Die Färbung in grün habe ich nur hilfsweise eingefügt."

Fehler bei Antwort #7
Laufzeitfehler '-2147467259 (80004005)':
Die Methode 'Export für das Objekt '_Chart' ist fehlgeschlagen
bei Code:
.Export Filename:=ZielPfad & Range(adrCell$).Offset(-1, 3)

Die Bilder werden zusätzlich in Excel gespeichert.
Außerdem werden nur Bilder der QR-Codes erstellt. Ich benötige den auch den Bereich um die QR-Codes (s.o.).

Fehler bei Antwort #11
Laufzeitfehler '53':
Datei nicht gefunden
bei Code:
Shell c00 & c01 & " /clippaste /convert=G:\OF\" & it.Name & ".png", 0

Code #15 muss ich morgen vom Arbeitsrechner testen (s.o.)

Nur nochmal zur Info. Die Bilder sollen dem Muster wie in der Beispiel-Datei entsprechen. Ich habe nochmal ein Bild als Muster beigefügt.
Insgesamt müssten so ca. 200 Bilder erzeugt werden. Ich hatte unterschätzt, dass dies für den Arbeitsspeicher eine zu große Herausforderung sein kann.

Liebe Grüße und einen schönen Sonntag

[snb]

Datei nicht gefunden
bei Code:
Shell c00 & c01 & " /clippaste /convert=G:\OF\" & it.Name & ".png", 0

1. Hast du Irfanview installiert ?
2. du solltest G:\OF\  anpassen müssen
3. schon getestet ??

 

Code:

  msgbox c00 & c01
   Shell c00 & c01 & " /clippaste /convert=C:\" & it.Name & ".png", 0

[Raisix]

Hallo snb. Vielen Dank für die schnelle Rückmeldung und die Hilfe.

Zu den Bemerkungen:

1. Hast du Irfanview installiert ?

--> ja (gerade nochmal die Version aktualisiert)

2. du solltest G:\OF\  anpassen müssen

--> egal, wie ich es anpasse, es funktioniert leider nicht. Selbst mit "Shell c00 & c01 & " /clippaste /convert=C:\" & it.Name & ".png", 0" nicht

3. schon getestet ??

--> ja, ich habe es getestet. Es erscheint leider immer:
Laufzeitfehler '53':
Datei nicht gefunden

Die Messagebox zeigt "CESSORS=4\Irfanview\" an

[snb]

De brauchst das fullpath von irfanview

Hier ist das z.B
F:\Irfanview\i_view32.exe

Und dann:

Shell "F:\Irfanview\i_view32.exe  /clippaste /convert=C:\" & it.Name & ".png", 0

Und wenn die Umgebung auch kopiiert werden muss:

Code:

Sub M_snb()
   For Each it In Tabelle1.Shapes
      it.TopLeftCell.Offset(-1).Resize(2, 2).CopyPicture
      Shell "F:\Irfanview\i_view32.exe  /clippaste /convert=C:\" & it.Name & ".png", 0
   Next
End Sub

[Egon12]

Hallo,
der Fehler in #7 ensteht, da Range nicht mit dem Tabellenblatt veknüpft ist.
ändere so:

Code:

Sub BilderExportieren()
    Dim objShape As Shape, objChart As ChartObject, adrCell$
    For Each objShape In Tabelle1.Shapes
        adrCell$ = objShape.TopLeftCell.Cells.Address
        If Tabelle1.Range(adrCell$).Offset(-1, 0).Interior.Color = RGB(0, 176, 80) Then
            objShape.CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Set objChart = ActiveSheet.ChartObjects.Add(0, 0, objShape.Width, objShape.Height)
            With objChart.Chart
                .Paste
                .Export Filename:=ZielPfad & Tabelle1.Range(adrCell$).Offset(-1, 3).Text
            End With
            objChart.Delete
        End If
    Next
End Sub

@ Alle an diesem Thema Interessierten:

Ich hatte mir mal in einer VirtuellBox Office 2007 und XP wegen Test zu API Kram installiert.
Unter dieser Installation hab ich meine Prozedur mit 200 Shapes drüber laufen lassen. Alles zügig (1 Min. 20 Sek.  +- 2 Sekunden) und ohne Probleme bzw. ohne leere (weiße) Jpeg's.

Unter Win 10 +O2019 keine Chance.
Eine Idee hab ich aber noch. Wie wäre es die Shapes nach PPT zu kopieren und via Methode Shape.SaveAsPicture Diese zu speichern.

Gruß Uwe