Mit vba Bilder aus einem Ordner einfügen

[Anderson277]

Hallo, 

Ich suche eine Möglichkeit alle Bilder (egal wie die Bilder benannt sind) aus einem bestimmten Ordner mit einem Klick auf einen Button in meine Tabelle zu bekommen. 
 Die Bilder sollten am besten gleich in eine bestimmte Breite formatiert werden. 

Der Ordnerpfad steht in einer Zelle

Ich hoffe hier kann mir jemand weiterhelfen.

Vielen Dank im Voraus

[snb]

Warum reicht menu / insert /Picture nicht ?

[Anderson277]

Hallo, 

Ich muss täglich ca 5-8 mal 8-10 Bilder aus immer wieder anderen Ordnern einfügen und in eine bestimmte größe formatieren. Den Pfad der Ordner kann ich über die Excel per Formel erstellen lassen.

Währe eine super Zeitersparnis für mich.

Mit vba kenn ich mich leider nicht aus und google hat nicht das gewünschte Ergebnis geliefert.

[00202]

Hallo,  

Kommentare im Code - damit kannst du den VBA-Code an deine Gegebenheiten anpassen:  

Code:

Option Explicit
Public Sub Main()
    Dim strPath As String
    Dim strFile As String
    Dim lngTMP As Long
    On Error GoTo Fin
    ' Fang ab Zeile 2 mit einfügen an
    lngTMP = 2
    ' für With Tabelle1 - siehe https://docs.microsoft.com/de-de/office/vba/api/excel.worksheet.codename
    With Tabelle1
        ' ALLE Bilder auf dem Tabellenblatt werden gelöscht!!! Musst du anpassen, wenn noch Bilder auf dem Blatt übrig bleiben sollen!!!
        .Pictures.Delete
        ' Pfad steht in Zelle G1
        strPath = .Range("G1").Value
        ' Ist der Pfad in G1 ohne abschließenden Baqckslash angegeben wir er anngefügt
        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        ' Hol die erste Datei - Grafikformat PNG, also gegebenenfalls anpassen
        strFile = Dir$(strPath & "*.png")
        ' Schleife, bis keine PNG-Datei mehr da ist
        Do While strFile <> ""
            ' Füge das Bild in D2 bzw. D2 folgende ein. Mit den Maßen von D2 - also Left (Links), Top (Oben), Width (Breite) und Height (Höhe)
            .Shapes.AddPicture strPath & strFile, -1, -1, .Range("D" & lngTMP).Left, .Range("D" & lngTMP).Top, .Range("D" & lngTMP).Width, .Range("D" & lngTMP).Height
            ' Laufzähler für Zelle eins hochzählen
            lngTMP = lngTMP + 1
            ' Nächste Grafikdatei abrufen
            strFile = Dir$()
        Loop
    End With
Fin:
    ' Wenn ein Fehler auftritt, gib ihn mit Fehlernummer und Beschreibung aus
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
End Sub

[Anderson277]

Hallo Case, 

Das einfügen der Bilder funktioniert genau so wie ich mir das vorgestellt habe.

Danke schonmal dafür  :)

Ich habe versucht über Google etwas über das Löschen der Bilder herauszufinden, leider ohne Erfolg. (ich suche vermutlich auch falsch) 

Auf der Tabelle befinden sich 2 bilder die nicht gelöscht werden dürfen, wie kann ich das realisieren? 

Des weiteren benötige ich die Bilder immer in einer bestimmten Breite aber die Höhe muss sich automatisch anpassen damit die Bilder nicht verzerren.

[00202]

Hallo,  

dann probiere es mal so:  

Code:

Option Explicit
Public Sub Main()
    Dim shpShape As Shape
    Dim strPath As String
    Dim strFile As String
    Dim lngTMP As Long
    On Error GoTo Fin
    ' Fang ab Zeile 2 mit einfügen an
    lngTMP = 2
    ' für With Tabelle1 - siehe https://docs.microsoft.com/de-de/office/vba/api/excel.worksheet.codename
    With Tabelle1
        ' ALLE Bilder auf dem Tabellenblatt werden gelöscht!!! Musst du anpassen, wenn noch Bilder auf dem Blatt übrig bleiben sollen!!!
        '.Pictures.Delete
        ' Hier werden nur Bilder mit bestimmtem Namen gelöscht. Den vergeben wir beim einfügen unten
        ' Durchlaufe alle Shapes auf dem Tabellenblatt
        For Each shpShape In .Shapes
            ' Wenn der Name "Picture" plus irgendwas ist - bei uns eine Nummer...
            If shpShape.Name Like "Picture" & "*" Then
                ' ... dann lösche das Bild...
                shpShape.Delete
            End If
        ' ... sonst gehe zum Nächsten
        Next shpShape
        ' Pfad steht in Zelle G1
        strPath = .Range("G1").Value
        ' Ist der Pfad in G1 ohne abschließenden Backslash angegeben wird er angefügt
        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        ' Hol die erste Datei - Grafikformat PNG, also gegebenenfalls anpassen
        strFile = Dir$(strPath & "*.png")
        ' Schleife, bis keine PNG-Datei mehr da ist
        Do While strFile <> ""
            ' Füge das Bild in D2 bzw. D2 folgende ein. Mit den Maßen von D2 - also Left (Links), Top (Oben),
            ' Width (Breite) und Height (Höhe) bleiben Original
            ' siehe - https://docs.microsoft.com/de-DE/office/vba/api/Excel.Shapes.AddPicture
            Set shpShape = .Shapes.AddPicture(strPath & strFile, -1, -1, .Range("D" & lngTMP).Left, .Range("D" & lngTMP).Top, -1, -1)
            With shpShape
                ' Mit "False" können Breite und Höhe unabhängig voneinander geändert werden - mit "True" wird angepasst
                ' siehe - https://docs.microsoft.com/de-de/office/vba/api/excel.shaperange.lockaspectratio
                .LockAspectRatio = True
                .Name = "Picture" & lngTMP
                .Width = .Parent.Range("D" & lngTMP).Width
            End With
            ' Laufzähler für Zelle eins hochzählen
            lngTMP = lngTMP + 1
            ' Zugewiesenes Objekt leeren, auf Nichts setzen
            Set shpShape = Nothing
            ' Nächste Grafikdatei abrufen
            strFile = Dir$()
        Loop
    End With
Fin:
    ' Zugewiesenes Objekt leeren, auf Nichts setzen
    Set shpShape = Nothing
    ' Wenn ein Fehler auftritt, gib ihn mit Fehlernummer und Beschreibung aus
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
End Sub

Thema hier - "LockAspectRatio". Siehe Kommentare und Links im Code. Beim löschen der Bilder gehe ich hier über einen vergebenen Namen. Du kannst auch löschen nach Range, Spalte oder...

[Anderson277]

Jetzt läuft alles wie gewünscht. 

Musste nur die Bildernamen von Picture zu was anderem ändern. 

Ich danke dir vielmals :)