Hallo Julian,
du hast aber auch Wünsche ;-):
[code]Sub Bilder_einlesen_neu()
Dim strPfad As String
Dim DateiName As String
Dim lngZaehler As Long
Dim lngSpalte As Long
Dim lngZeile As Long
Dim rngSpalte As Range
Dim rngText As Range
Dim lngSeite As Long
With Application
.ScreenUpdating = False 'Bildschirmaktualisierung ausschalten
.EnableEvents = False 'Ereignisse
.Calculation = xlCalculationManual 'automatische Berechnung ausschalten
End With
'erste Zeile und Spalte zum Einfügen festlegen
lngZeile = 1
lngSpalte = 1
'Zähler für Seiten
lngSeite = 1
'Tabelle einrichten
'Spalten für Bilder Breite von 17,75 festlegen
With ActiveSheet
Set rngSpalte = .Range("A:A,C:C,E:E,G:G,I:I,K:K,M:M,O:O")
rngSpalte.ColumnWidth = 17.75
'Spalten für Erläuterungen Breite von 20 festlegen
Set rngSpalte = .Range("B:B,D:D,F:F,H:H,J:J,L:L,N:N,P:P")
rngSpalte.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 und png öffnen
DateiName = Dir(strPfad)
Do While DateiName <> ""
If LCase(Right(DateiName, 3)) = "jpg" Or LCase(Right(DateiName, 3)) = "png" Then
lngZaehler = lngZaehler + 1 'Zähler für Bilder
'Zeile und Spalte für das einzufügende Bild festlegen
If lngZaehler > 1 Then
If lngZaehler Mod 8 = 1 Then 'ist Zähler ungrade
lngZeile = lngZeile + 12 'dann neue Zeile festlegen
lngSpalte = 1
lngSeite = lngSeite + 1
Else
If lngZaehler > 1 Then lngSpalte = lngSpalte + 2
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
'Prüfen ob 4 Bildereihen eingefügt wurden
If lngSeite = 5 Then
'falls ja, dann Zähler auf 1 zurücksetzen
lngSeite = 1
'und Seitenumbruch vor neuer Einfügezeile einfügen
.Rows(lngZeile).PageBreak = xlPageBreakManual
End If
'Bilder einfügen
.Shapes.AddPicture strPfad & DateiName, msoFalse, msoTrue, .Cells(lngZeile, lngSpalte).Left, .Cells(lngZeile, lngSpalte).Top + 1, 110, 140
'Text einfügen und formatieren
With .Cells(lngZeile, lngSpalte + 1)
.Value = "Lego Star-Wars"
.HorizontalAlignment = xlCenter 'zentrieren
With .Font
.Name = "Calibri" 'Schriftart
.Size = 14 'Schriftgröße
.Bold = True 'Fett
.Underline = xlUnderlineStyleSingle 'unterstrichen
End With
End With
'Text einfügen, soweit vorhanden
.Cells(lngZeile + 1, lngSpalte + 1).Value = "Name:"
.Cells(lngZeile + 3, lngSpalte + 1).Value = "Farben:"
.Cells(lngZeile + 6, lngSpalte + 1).Value = "Preis ca.:"
.Cells(lngZeile + 8, lngSpalte + 1).Value = "Set Nr.:"
'und formatieren
Set rngText = Union(.Cells(lngZeile + 1, lngSpalte + 1), .Cells(lngZeile + 3, lngSpalte + 1), .Cells(lngZeile + 6, lngSpalte + 1), .Cells(lngZeile + 8, lngSpalte + 1))
With rngText.Font
.Size = 12 'Schriftgröße
.Bold = True 'Fett
.Underline = xlUnderlineStyleSingle 'unterstrichen
End With
'Nun leere Zeilen für Text formatieren
Set rngText = Union(.Cells(lngZeile + 2, lngSpalte + 1), .Cells(lngZeile + 4, lngSpalte + 1), .Cells(lngZeile + 5, lngSpalte + 1), .Cells(lngZeile + 7, lngSpalte + 1), .Cells(lngZeile + 9, lngSpalte + 1))
With rngText
.HorizontalAlignment = xlCenter 'zentrieren
With .Font
.Size = 12 'Schriftgröße
.Italic = True 'kursiv
End With
End With
'Zeile für Preis mit Euro formatieren
.Cells(lngZeile + 7, lngSpalte + 1).NumberFormat = "#,##0.00 $"
End With
End If
DateiName = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub[/code]
Gruß
M.O.