VBA Schleife Bilder aus Excel exportieren

[Raisix]

Ich danke euch ganz herzlich für eure Hilfe. Das ist wirklich mehr, als ich erwartet habe. Sehr smarte Lösungen! Ich bin richtig begeistert.

Ich habe die Lösung von snb um einen Teil von Uwes Lösung ergänzt. Jetzt macht das Modul genau das, was ich benötige!

Code:

Sub M_snb()

  Dim adrCell$

  For Each it In Tabelle1.Shapes
 
      adrCell$ = it.TopLeftCell.Cells.Address
      it.TopLeftCell.Offset(-1).Resize(2, 2).CopyPicture
      Shell "C:\Program Files\IrfanView\i_view64.exe  /clippaste /convert=E:\Gemeinsame Dateien\Munzee\20241011_Homezone_Bilder_VBA\" & Tabelle1.Range(adrCell$).Offset(-1, 3).Text & ".jpg", 0

  Next
End Sub

[schauan]

Hallöchen,

#15 resultiert daher, dass der code für 64 bit ist. Die Deklarationen können aber auch für 32 und 64 bit ausgeführt werden, am Anfang denn

Code:

#If VBA7 Then
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)
#Else
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If

[snb]

Kann einfacher:

Code:

Sub M_snb()
  For Each it In Tabelle1.Shapes
    it.TopLeftCell.Offset(-1).Resize(2, 2).CopyPicture
    Shell "C:\Program Files\IrfanView\i_view64.exe /clippaste /convert=E:\Gemeinsame Dateien\Munzee\20241011_Homezone_Bilder_VBA\" & it.topleftcell.Offset(-1, 3).Text & ".jpg", 0
  Next
End Sub

[Egon12]

Hallo Miteinander,

für alle, die sich für einen Lösungsweg ohne Zuhilfenahme von IrfanView oder o.ä. interessieren, habe ich mal das Beispiel für eine API Lösung von André (@schauan) zu dieser Problematik zurecht gemacht.

Code:

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    'Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)    ' nur falls erforderlich
#Else
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)    ' nur falls erforderlich
#End If
Private Const ZielPfad As String = "C:\Users\....\"
Sub SavePict()
    Dim pict As Shape, adrCell$, i&
    For Each pict In Tabelle1.Shapes
        pict.Copy
        adrCell = pict.TopLeftCell.Cells.Address
        GraphicsExport pict, Tabelle1.Range(adrCell$).Offset(-1, 3), "jpg", 1
        'i = i + 1
        'If i = 100 Then Exit Sub  ' Begrenzung der Durchläufe zwecks Test
    Next
End Sub
'-----------------------------------------------------------------
'--- Zwischenablage leeren ---
'-----------------------------------------------------------------
Sub ClearClipboard()
    OpenClipboard 0&
    EmptyClipboard
    CloseClipboard
End Sub
'-----------------------------------------------------------------
'--- Bild exportieren ---
'-----------------------------------------------------------------
Private Sub 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#, icnt&
    Const TIMEOUT = 0.5 ' Seconds between repeating of CopyPicture
    Const ATTEMPTS = 10 ' Attempts of CopyPicture repeating
    Set tempSheet = ActiveSheet
    Set shPict = pict
    PictName = PictName
    Set tempDia = tempSheet.Shapes.AddChart.Chart
    For icnt = 1 To ATTEMPTS    'sicher gehen, dass das Kopieren geklappt hat
        Application.CutCopyMode = False: ClearClipboard
        DoEvents
        shPict.Copy
        If Err Then
            Err.Clear
            t = Timer + TIMEOUT
            While Timer < t
            DoEvents
            Wend
        Else
            Exit For
        End If
    Next
    With tempDia    'und nun das Diagramm anpasse
        .Parent.Height = pict.Height + 1
        .Parent.Width = pict.Width + 1
        .Paste
        DoEvents
        .Parent.Height = .Parent.Height * PictRatio
        .Parent.Width = .Parent.Width * PictRatio
        .Export ZielPfad & PictName, PictType, False
        'Sleep 50   ' nur falls erforderlich
        .ChartArea.Clear 'Bild im Diagramm loeschen
    End With
    Set shPict = Nothing
    Set tempDia = Nothing
End Sub

Gruß Uwe

[snb]

@Egon

Code:

it.TopLeftCell.Offset(-1).Resize(2, 2).CopyPicture

<>

Code:

pict.Copy

nicht nur das Bild doch die Zelle oben un neben das Bild sollen mitkopiiert werden.

Und ist dann deine approach nicht ähnlich zu:

Code:

Sub M_snb()
   With Sheets(1).ChartObjects.Add(400, 60, 80, 80).Chart
     For Each it In Tabelle1.Shapes
       it.TopLeftCell.Offset(-1).Resize(2, 2).CopyPicture
       .Paste
       .Export "G:\OF\" & Replace(it.TopLeftCell.Offset(-1, 3), ".jpg", "") & ".jpg"
     Next
     .Parent.Delete
   End With
End Sub

[Egon12]

@ snb,

stimmt, das hatte ich überlesen. Aber kein Problem das wäre dann so:

Code:

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    'Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)    ' nur falls erforderlich
#Else
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)    ' nur falls erforderlich
#End If
Private Const ZielPfad As String = "C:\Users\...\"

Sub SavePict()
    Dim pict As Shape, adrCell$, i&
    For Each pict In Tabelle1.Shapes
        pict.Copy
        adrCell = pict.TopLeftCell.Cells.Address
        GraphicsExport pict, Tabelle1.Range(adrCell$).Offset(-1, 3), "jpg", 1
        'i = i + 1
        'If i = 100 Then Exit Sub  ' Begrenzung der Durchläufe zwecks Test
    Next
End Sub

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

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

Private Sub 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#, icnt&
    Const TIMEOUT = 0.5 ' Seconds between repeating of CopyPicture
    Const ATTEMPTS = 10 ' Attempts of CopyPicture repeating
    Set tempSheet = ActiveSheet
    Set shPict = pict
    PictName = PictName
    Set tempDia = tempSheet.Shapes.AddChart.Chart
    For icnt = 1 To ATTEMPTS    'sicher gehen, dass das Kopieren geklappt hat
        Application.CutCopyMode = False: ClearClipboard
        DoEvents
        'shPict.Copy
        shPict.TopLeftCell.Offset(-1).Resize(2, 2).CopyPicture
        If Err Then
            Err.Clear
            t = Timer + TIMEOUT
            While Timer < t
            DoEvents
            Wend
        Else
            Exit For
        End If
    Next
    With tempDia    'und nun das Diagramm anpasse
        .Parent.Height = pict.Height + 1
        .Parent.Width = pict.Width + 1
        .Paste
        DoEvents
        .Parent.Height = .Parent.Height * PictRatio
        .Parent.Width = .Parent.Width * PictRatio
        .Export ZielPfad & PictName, PictType, False
        'Sleep 50   ' nur falls erforderlich
        .ChartArea.Clear 'Bild im Diagramm loeschen
    End With
    Set shPict = Nothing
    Set tempDia = Nothing
End Sub

Gruß Uwe

[snb]

Dann verstehe ich nicht:

Code:

        pict.Copy

und

Code:

shPict.TopLeftCell.Offset(-1).Resize(2, 2).CopyPicture

[Egon12]

@snb,
 
ich verstehe es schon.
Was ich geändert habe gibt neben dem Shape die Zellen oben und rechts mit ins jpg.
Das klappt mit .copy logischerweise nicht.

Gruß Uwe

[snb]

Dann scheint mir pict.copy überflüssig.

[Egon12]

ja, das stimmt. In diese Prozedur hatte ich nicht mehr reingeschaut.

richtig so:

Code:

Sub SavePict()
    Dim pict As Shape, adrCell$, i&
    For Each pict In Tabelle1.Shapes
        adrCell = pict.TopLeftCell.Cells.Address
        GraphicsExport pict, Tabelle1.Range(adrCell$).Offset(-1, 3), "jpg", 1
        'i = i + 1
        'If i = 10 Then Exit Sub  ' Begrenzung der Durchläufe zwecks Test
    Next
End Sub

Danke für den Hinweis.

Die Zeile "PictName = PictName" kann zumindest im Zusammenhang mit der Beispieldatei ebenfalls raus.
Falls da aber noch was dran geändert werden soll z.B.: es soll eine Dateierweiterung mitgegeben werden muss braucht es aber diese Zeile entsprechend angepasst wieder.

Gruß Uwe