Bilder automatisch per Button einfügen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo arek,
nachstehender Code auf den schon eingefügten Button gelegt, durchsucht alle von Dir angegebenen Ordner (Jahr) und deren Unterordner (SerienNr) auf dem Desktop und fügt die Bilder in ein neues Tabellenblatt ein.
Dort erhalten alle Bilder eine einheitliche Breite, sofern sie nicht schmaler sind.
Gruß
Robert

Private Sub CommandButton1_Click()
Dim strVerz As String, strDatei As String, pic As Picture
Dim iBreite As Integer, iAnz As Integer, lAnz As Long, lZ As Long
Dim WSH As Object 'Windows Scripting Host
Dim wksBilder As Worksheet, wksDaten As Worksheet
Set WSH = CreateObject("WScript.Shell")
Set wksDaten = ActiveSheet
'Bilder-Breite
iBreite = 300
'Anzahl der Bilder-Verzeichnisse
lAnz = Range("A" & Rows.Count).End(xlUp).Row
'Tabellenblatt für Bilder erstellen
Sheets.Add After:=Sheets(Sheets.Count)
Set wksBilder = ActiveSheet
'Verzeichnisse durchlaufen
For lZ = 2 To lAnz
'Bild-Dateinamen ermitteln
strVerz = WSH.SpecialFolders("Desktop") & "\" & wksDaten.Cells(lZ, 1) & "\" & wksDaten. _
Cells(lZ, 2) & "\"
strDatei = Dir(strVerz & "*.jpg")
'Bilder einfügen
Do While strDatei  ""
iAnz = iAnz + 1
Set pic = ActiveSheet.Pictures.Insert(strVerz & "\" & strDatei)
If pic.Width > iBreite Then pic.Width = iBreite
pic.Left = (iAnz - 1) * (iBreite + 10)
pic.Top = 1
strDatei = Dir    ' Nächsten Eintrag abrufen.
Loop
Next
'Aufräumen
Set pic = Nothing
Set wksBilder = Nothing
Set wksDaten = Nothing
End Sub

Private Sub CommandButton1_Click() Dim strVerz As String, strDatei As String, pic As Picture Dim iBreite As Integer, iAnz As Integer, lAnz As Long, lZ As Long Dim WSH As Object 'Windows Scripting Host Dim wksBilder As Worksheet, wksDaten As Worksheet Dim lHoehe As Long, lBildHoehe As Integer Application.ScreenUpdating = False Set WSH = CreateObject("WScript.Shell") Set wksDaten = ActiveSheet 'Bilder-Breite iBreite = 300 'Anzahl der Bilder-Verzeichnisse lAnz = Range("A" & Rows.Count).End(xlUp).Row 'Tabellenblatt für Bilder erstellen Sheets.Add After:=Sheets(Sheets.Count) Set wksBilder = ActiveSheet 'Verzeichnisse durchlaufen For lZ = 2 To lAnz 'Bild-Dateinamen ermitteln strVerz = WSH.SpecialFolders("Desktop") & "\" & wksDaten.Cells(lZ, 1) & "\" & wksDaten. _ Cells(lZ, 2) & "\" strDatei = Dir(strVerz & "*.jpg") 'Bilder einfügen Do While strDatei "" For iAnz = 1 To 3 '3 Bilder pro Zeile If iAnz = 1 Then lHoehe = lHoehe + lBildHoehe + 10 Set pic = ActiveSheet.Pictures.Insert(strVerz & "\" & strDatei) If pic.Width > iBreite Then pic.Width = iBreite pic.Left = (iAnz - 1) * (iBreite + 10) pic.Top = lHoehe If iAnz > 1 Or lBildHoehe

For iAnz = 1 To 3 If InStr(strDatei, wksDaten.Cells(lZ, 3)) > 0 Then If iAnz = 1 Then lHoehe = lHoehe + lBildHoehe + 10 Set pic = ActiveSheet.Pictures.Insert(strVerz & "\" & strDatei) If pic.Width > iBreite Then pic.Width = iBreite pic.Left = (iAnz - 1) * (iBreite + 10) pic.Top = lHoehe If iAnz > 1 Or lBildHoehe

Beliebteste Forumthreads (12 Monate)

Bilder automatisch per Button einfügen

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bilder automatisch per Button einfügen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread