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
Warum reicht menu / insert /Picture nicht ?
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.
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
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.
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...
Jetzt läuft alles wie gewünscht.
Musste nur die Bildernamen von Picture zu was anderem ändern.
Ich danke dir vielmals :)