Hallo Julian,
das folgende Makro gehört in ein [url=
http://www.excelbeispiele.de/Modul.htm]Modul[/url] der Arbeitsmappe(n).
Das Makro formatiert die Seite so, dass jeweils 4 x 2 Bilder auf eine Seite passen. Auch die Spaltenbreiten werden entsprechend angepasst.
Ist das Makro gestartet wird zuerst die Seite eingerichtet. Dann wirst du aufgefordert, einen Pfad für den Import der Bilder auszuwählen. Es werden nur jpg-Dateien eingelesen. Ggfs. musst die Endung im Makro ändern. Es werden keine Unterverzeichnisse eingelesen.
[code]Sub Bilder_einlesen()
Dim strPfad As String
Dim DateiName As String
Dim lngZaehler As Long
Dim lngSpalte As Long
Dim lngZeile As Long
With Application
.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
.EnableEvents = False 'Ereignisse ausschalten
.Calculation = xlCalculationManual 'automatische Berechnuns ausschalten
End With
'erste Zeile und Spalte zum Einfügen festlegen
lngZeile = 1
lngSpalte = 1
'Tabelle einrichten
'Spalten A und C (für Bilder) Breite von 22,29 festlegen
With ActiveSheet
.Columns("A:A").ColumnWidth = 22.29
.Columns("C:C").ColumnWidth = 22.29
'Spalten B und D (für Erläuterungen) Breite von 20 festlegen
.Columns("B:B").ColumnWidth = 20
.Columns("D:D").ColumnWidth = 20
'Seitenränder (jeweils 1,5 cm) einrichten
With .PageSetup
.LeftMargin = Application.InchesToPoints(0.590551181102362) 'linker Seitenrand
.RightMargin = Application.InchesToPoints(0.590551181102362) 'rechter Seitenrand
.TopMargin = Application.InchesToPoints(0.590551181102362) 'oberer Seitenrand
.BottomMargin = Application.InchesToPoints(0.590551181102362) 'unterer Seitenrand
End With
End With
'Pfad auswählen und in Variable für Pfad schreiben
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Bitte Ordner wählen"
.InitialFileName = ""
.InitialView = msoFileDialogViewThumbnail
.ButtonName = "OK"
If .Show = -1 Then
strPfad = .SelectedItems(1) & "\"
Else
MsgBox "Kein Pfad gewählt! Abbruch!", 16, "Abbruch!" 'Abbrechen wenn kein Pfad ausgewählt wurde
Exit Sub
End If
End With
'nur Dateien mit Endung .jpg öffnen - Endung ggf. anpassen!
DateiName = Dir(strPfad & "*.jpg")
Do While DateiName <> ""
lngZaehler = lngZaehler + 1 'Zähler
'Zeile und Spalte für das einzufügende Bild festlegen
If lngZaehler > 1 Then
If lngZaehler Mod 2 = 1 Then 'ist Zähler ungrade
lngZeile = lngZeile + 13 'dann neue Zeile festlegen
Else
If lngZaehler > 1 Then 'ansonsten Einfügespalte neu festlegen
If lngSpalte = 1 Then
lngSpalte = 3 'Spalte C
Else 'oder
lngSpalte = 1 'Spalte A
End If
End If
End If
End If
'Bilder einfügen
'Bild in Zellen einfügen, 4,3 cm breit - 1 cm = = 28,35 pt ergibt 121,91 pt - und 6,64 cm hoch = 188,24
With ActiveSheet
.Shapes.AddPicture strPfad & DateiName, msoFalse, msoTrue, .Cells(lngZeile, lngSpalte).Left, .Cells(lngZeile, lngSpalte).Top + 1, 122, 188
End With
DateiName = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
[/code]
Gruß
M.O.