AW: verzeichniss auslesen und Hyperlinks setzen
27.01.2005 15:26:33
Marc
Viel Spass!
Gruß
Sub Dateien_als_Hyperlink_listen()
' Listet alle Dateien als Hyperlink
Application.ScreenUpdating = False
Dim myFSO As Object
Dim myDrvList, myDrv, mySpace
Dim Dateiform As String, myStr As String
Dim geffile As String
Dim i As Long, totFiles As Long, chkHype As Integer
Dim oldStatus As Variant
Set myFSO = CreateObject("Scripting.Filesystemobject")
Set myDrvList = myFSO.drives
Application.ScreenUpdating = True
oldStatus = Application.StatusBar
On Error GoTo myErrHandler
Dateiform = "*.*"
If Dateiform = "" Then
Application.ScreenUpdating = True
Exit Sub
End If
With Application.FileSearch
.LookIn = "C:\" '<------------------------------ Pfad anpassen
.SearchSubFolders = True 'True für Suche in allen Unterverzeichnissen!!
.Filename = Dateiform
If .Execute() > 0 Then
totFiles = .FoundFiles.Count
Application.StatusBar = "Total " & totFiles & " in " & mySpace & " gefunden "
For i = 1 To .FoundFiles.Count
geffile = .FoundFiles(i)
Cells([A65536].End(xlUp).Row + 1, 1) = geffile
ActiveSheet.Hyperlinks.Add Anchor:=Cells([A65536].End(xlUp).Row, 1), Address:=geffile _
, TextToDisplay:=geffile
Selection.Font.ColorIndex = 2
Next i
End If
End With
ErrEntry:
Application.StatusBar = oldStatus
Application.ScreenUpdating = True
MyExit:
Close #1
Exit Sub
myErrHandler:
Select Case Err
Case 71
myStr = myStr & "Datenträger nicht bereit"
End Select
Resume ErrEntry
End Sub