VBA-Beispiel 026
mail schreiben
mail schreiben

Dateiliste erstellen
Tipp: seit Nov 08 gibt es eine wesentlich verbesserte Variante um Dateilisten zu erstellen
siehe: Verzeichnisse durchsuchen und Dateilisten erstellen



Dieses Makro erstellt eine Liste aller Dateien eines bestimmten Ordners. Der Pfad zum Ordner wird per InputBox abgefragt.
Die Dateinamen werden als Hyperlink eingefügt.
Sub Versionskontrolle()
'FileSearch gibt es nur bis einschl. Excelversion 11

If Val(Application.Version) > 11 Then
  MsgBox "Dieses Makro funktioniert nur bis einschl. Excelversion 11.0" _
          & vbNewLine & _
          "Sie haben aber Excel: " & Application.Version _
          & vbNewLine & vbNewLine _
          & "keine Änderungen durchgeführt", , "kann Makro nicht ausführen"
  Exit Sub
Else
  Call Dateiliste
End If

End Sub


Sub Dateiliste()
Dim pfad As String, such As String
Dim Text As String, xxl As String
Dim i As Integer, y As Integer, z As Integer
Dim info As Integer, x As Integer, anz As Integer
Dim fs

Set fs = Application.FileSearch

pfad = InputBox("Geben Sie den Pfad ein", , "C:\Eigene Dateien")
If pfad = "" Then Exit Sub
With fs
    .LookIn = pfad
    .Filename = "*.*"
  'wenn der Pfad nicht existiert Programm abbrechen
   If Dir(pfad, vbDirectory) = "" Then
      MsgBox "Falsche Pfadangabe !  Das Verzeichnis" & _
              vbCrLf & "' " & pfad & " '" & _
              vbCrLf & "existiert nicht !", _
              vbExclamation, "Fehlermeldung"
        Exit Sub
    End If

    If .Execute(SortBy:=msoSortByFileName, _
    SortOrder:=msoSortOrderAscending) > 0 Then
    z = Len(.LookIn)
    such = "\"
    Cells(2, 2) = pfad & " " & .FoundFiles.Count & " Dateien"
    y = 3
        For i = 1 To .FoundFiles.Count
        Cells(y, 2) = .FoundFiles(i)

            Text = Cells(y, 2)
            anz = Len(Cells(y, 2))
            such = "\"

          For x = 1 To anz
          info = InStr(info + 1, Text, such)
          If info = 0 Then GoTo weiter
          Cells(y, 2) = Right(Text, anz - info)
          xxl = Cells(y, 2)
            With ActiveSheet
            .Hyperlinks.Add Anchor:=.Cells(y, 2), Address:=Text, _
            TextToDisplay:=xxl
            End With
          Next x
weiter:
        y = y + 1
        Next i

    Columns("B:B").AutoFit
    Else
        MsgBox "Keine Dateien gefunden"
    End If
End With
   With Columns("B:B").Font
        .Name = "Arial"
        .FontStyle = "Standard"
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 5
    End With
    With Cells(2, 2).Font
        .Name = "Arial"
        .FontStyle = "Standard"
        .Size = 10
        .ColorIndex = xlAutomatic
        .Bold = True
    End With
End Sub
Download:   vba026.zip
relevante Links:

top