AW: alle Bilder eines Ordners öffnen
20.06.2005 19:59:09
Hajo_Zi
Hallo Rocky,
passse Dir folgendes Mako an.
Sub Sammeln2()
' Bildgröße verändern
Dim Höhe As Integer
Dim SHöhe As Single
Dim Breite As Integer
Dim SBreite As Integer
Dim J As Integer
Dim Wert1
Höhe = 34
Breite = 5
SBreite = 1
SHöhe = 2
Dim strVerzeichnis$, strDatei$
Dim pct As Picture
strVerzeichnis = "D:\Eigene Dateien\Eigene Bilder\Bilder\Sammeln"
strDatei = Dir(strVerzeichnis & "\*.jpg")
Cells(SHöhe, SBreite).Select
Cells(SHöhe - 1, SBreite) = strDatei ' schreiben Dateinamen
Set pct = ActiveSheet.Pictures.Insert(strVerzeichnis & "\" & strDatei) ' einfügen Bild
'With ActiveSheet.Shapes("Picture 1")
ActiveSheet.Shapes("Picture 1").Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 400.75
' Selection.ShapeRange.Width = 113.25
' End With
J = 2
SHöhe = SHöhe + Höhe
Do While strDatei <> ""
strDatei = Dir()
If strDatei = "" Then Exit Do
Cells(SHöhe, SBreite).Select
Set pct = ActiveSheet.Pictures.Insert(strVerzeichnis & "\" & strDatei)
ActiveSheet.Shapes("Picture " & J).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 400.75
' Selection.ShapeRange.Width = 113.25
J = J + 1
Cells(SHöhe - 1, SBreite) = strDatei
SHöhe = SHöhe + Höhe
If SHöhe >= 65500 Then
SBreite = SBreite + Breite
SHöhe = 2
End If
Loop
End Sub
Bitte keine Mail, Probleme sollten im Forum gelöst werden.
Microsoft MVP für Excel
Das Forum lebt auch von den Rückmeldungen.
Betriebssystem XP Home SP2 und Excel Version 2003 SP1.