Soo ich habe noch mal ein wenig selber probiert und mir die Maße sogar selber eingestellt bekommen ( keine Ahnung wie es funktioniert hat aber
egal^^ ).
Was jetzt echt noch genial wäre. wenn ich zu den bildern jeweils noch einen standard text einfügen könnte. In der 1. spalte neben bild rechts
- Lego Star Wars , Fett und unterstrichen Schriftgröße 14
- Name: Fett mit Unterstrich 12
-( Leere Zeile) 12
- Farben: Fett mit Unterstrich12
-( Leere Zeile)12
-( Leere Zeile )12
-Preis ca.: fett mit unterstrich12
-( Leere Zeile)12
Set Nr.: fett mit unterstrich
-( Leere Zeile)
Den geschriebenen Text von M.O. Habe ich so verändert :
Sub Bilder_einlesen()
Dim strPfad As String
Dim DateiName As String
Dim lngZaehler As Long
Dim lngSpalte As Long
Dim lngZeile As Long
Dim rngSpalte As Range
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 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")
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")
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 6 = 1 Then 'ist Zähler ungrade
lngZeile = lngZeile + 12 'dann neue Zeile festlegen
Else
If lngZaehler > 1 Then 'ansonsten Einfügespalte neu festlegen
lngSpalte = lngSpalte + 2
If lngSpalte > 11 Then lngSpalte = 1
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, 110, 140
End With
End If
DateiName = Dir
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
wäre cool wenn sich einer da noch mal die Zeit nimmt wenn nicht sogar der M.O. ;-)