Re: Ordner mit Bilddateien auslesen
24.01.2003 21:41:04
Steffan
Hallo Harald,ich hab mich mal mit Hyperlinks an die Sache rangetastet. Da genügt schon ein einfacher Klick, um das Bild zu öffen ;-)
Das einzige was noch m.E. noch fehlt ist eine komfortable Ordnerauswahl und noch etwas Errorhandling. Wenn Du in dieser Richtung weitermachen willst, dann meld Dich ein fach hier noch mal.
Steffan.
Sub bilddateien_lesen()
Dim ordner As String
Dim oBilder As Worksheet
Dim FS As FileSearch
Dim sName As StringApplication.ScreenUpdating = False
'VEREINBARUNGEN:
'Name des Bildauswahlblattes
sName = "Bildauswahl"
'Name des Orners
ordner = "C:\Eigene Dateien"
'ORDNER DURCHSUCHEN
'FileSearch definieren
Set FS = Application.FileSearch
With FS
.NewSearch
.LookIn = ordner
.SearchSubFolders = False
.FileType = msoFileTypeAllFiles
.Execute
End With
'BLATT ERSTELLEN UND EINRICHTEN
On Error GoTo fehler
Set oBilder = Worksheets.Add
oBilder.Name = sName
'Blattkopf
oBilder.Cells(1, 1).Value = "Bilder aus " & ordner
oBilder.Cells(2, 1).Value = "Vorschau"
oBilder.Cells(2, 2).Value = "Link"
With oBilder.Cells(1, 1).Font
.Bold = True
.Size = .Size + 4
End With
With oBilder.Range(Cells(2, 1), Cells(2, 2)).Font
.Bold = True
.Size = .Size + 2
End With
'DATEIEN AUS ORDNER EINLESEN
On Error GoTo 0
Dim iZeile As Integer
iZeile = 4
For i = 1 To FS.FoundFiles.Count
'Vereinbarung der Typen, die gesucht werden können
If FS.FoundFiles(i) Like "*.jpg" Or _
FS.FoundFiles(i) Like "*.tif" Or _
FS.FoundFiles(i) Like "*.bmp" Then
'Festsetzung von Bild- und Zeilenhöhe
oBilder.Rows(iZeile).RowHeight = 50
'Text vertikal mittig in Zeile
oBilder.Rows(iZeile).VerticalAlignment = xlVAlignCenter
'gefundenes Bild einfügen und Höhe auf Zeilenhöhe setzen
oBilder.Cells(iZeile, 1).Select
ActiveSheet.Pictures.Insert(FS.FoundFiles(i)).Select
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Height = 50
oBilder.Hyperlinks.Add Anchor:=.Item(1), Address:=FS.FoundFiles(i)
End With
'maximale Breite merken
If Selection.ShapeRange.Width > maxWidth Then _
maxWidth = Selection.ShapeRange.Width
'Hyperlink mit Dateinamen in Spalte B
oBilder.Hyperlinks.Add Anchor:=oBilder.Cells(iZeile, 2), _
Address:=FS.FoundFiles(i), _
TextToDisplay:=FS.FoundFiles(i), _
ScreenTip:="Hier klicken, um das Bild anzuzeigen ..."
'Zeilenzähler hochsetzen
iZeile = iZeile + 2
End If
Next
'Breite der 1. Spalte auf max. Breite, der 2. Spalte auf optimale Breite
maxWidth = maxWidth * oBilder.Columns(1).ColumnWidth / _
oBilder.Columns(1).Width + 5
If maxWidth > 255 Then maxWidth = 255
oBilder.Columns(1).ColumnWidth = maxWidth
oBilder.Columns(2).AutoFit
oBilder.Cells(3, 1).Select
Application.ScreenUpdating = True
Exit Sub
fehler:
If Err.Number = 1004 Then sName = sName & "_": Resume
End Sub