Re: Slid Show
11.05.2003 10:33:26
IVAN MARTINOV
hi hayo
danke super es funkt.
nur ich bekomme wenn das letzte bild gezeigt wurde
laufzeitfehler 1004
bild eigenschaft konnte nich zugeordnet werden!
und noch ne frage bei mir wird das verzeichniss in einem verzeivhnissbaum aufgerufen wo ich den ort der dateien immer auswählen kann wie kann ich das noch in deiner version ändern
das immer das ausgewählte verzeichniss dargestellt wird.
hier der code.Sub bilddateien_lesen()
Application.ScreenUpdating = False
Dim strInitialDir As String, strPath As String
Dim sFile As String, sPattern As String, sPath As String
Dim iRow As Integer
Columns(1).ClearContents
sPath = BrowseDirectory()
If sPath = "" Then Exit Sub
'einlesen
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
sPattern = "*.*"
Dim ordner As String
Dim oBilder As Worksheet
Dim FS As FileSearch
Dim sName As String
'Name des Bildauswahlblattes
sName = "Ohne Namen"
'ORDNER DURCHSUCHEN
'FileSearch definieren
Set FS = Application.FileSearch
With FS
.NewSearch
.LookIn = sPath
.SearchSubFolders = True
.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 " & sPath
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 = 3
For I = 1 To FS.FoundFiles.Count
'Vereinbarung der Typen, die gesucht werden können
If FS.FoundFiles(I) Like "*.*" Then
'Festsetzung von Bild- und Zeilenhöhe
oBilder.Rows(iZeile).RowHeight = 150
'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 = 150
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
Exit Sub
fehler:
If Err.Number = 1004 Then sName = sName & "_": Resume
Application.ScreenUpdating = True
End Sub
vielen dank ivan