AW: Verzeichnisse auflisten
29.06.2013 14:14:51
Tino
Hallo,
hier mal ein Code für die Ordner aufzulisten.
Option Explicit
Sub OrdnerAuflisten()
Dim n&, OrderName$, ArAusgabe(), ArOrdner()
Static strOrdner$
strOrdner = Ordnerauswahl(strOrdner)
If strOrdner = "" Then Exit Sub
GetSubFolders ArOrdner, strOrdner, n, False
With Tabelle1 'Ausgabe Tabelle
Events False
On Error GoTo ErrorHandler:
.Range("A2", .Cells(.Rows.Count, 1)).ClearContents 'alte Daten löschen (in A1 = Überschrift)
If n > 0 Then
Redim Preserve ArAusgabe(1 To Ubound(ArOrdner, 2), 1 To 1)
For n = Lbound(ArOrdner, 2) To Ubound(ArOrdner, 2)
'Formal für Hyperlink
ArAusgabe(n, 1) = "=HYPERLINK(""" & ArOrdner(0, n) & """,""" & ArOrdner(1, n) & """)"
Next n
'Ausgabe erste Zelle, hier A2
With .Range("A2").Resize(Ubound(ArAusgabe))
.FormulaR1C1 = ArAusgabe
.EntireColumn.AutoFit
End With
End If
ErrorHandler:
Events True
End With
End Sub
Private Sub GetSubFolders(myAr, strPfad As String, LCount As Long, booSubFolder As Boolean, Optional FSO As Object)
Dim FO As Object, FU As Object, F As Object
If FSO Is Nothing Then Set FSO = CreateObject("Scripting.FileSystemObject")
Set FO = FSO.GetFolder(strPfad)
Set FU = FO.SubFolders
On Error GoTo ErrZugriff: 'falls zugriff verweigert
For Each F In FU
If F.Attributes = 16 Then
LCount = LCount + 1
Redim Preserve myAr(1 To 2, 1 To LCount)
myAr(0, LCount) = F.Path
myAr(1, LCount) = F.Name
If booSubFolder Then GetSubFolders myAr, F.Path, LCount, booSubFolder, FSO
End If
Next
ErrZugriff:
End Sub
'Für Dialog Ordnerauswahl
Public Function Ordnerauswahl(Optional ByVal strVorgabe$) As String
Dim strOrdner As String
If strVorgabe = "" Then
strVorgabe = "C:\"
End If
strVorgabe = strVorgabe & IIf(Right$(strVorgabe, 1) = "\", "", "\")
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = strVorgabe
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strOrdner = .SelectedItems(1)
If Right(strOrdner, 1) <> "\" Then strOrdner = strOrdner & "\"
Else
strOrdner = ""
End If
End With
Ordnerauswahl = strOrdner
End Function
Sub Events(booOn As Boolean)
Static AltCalc%
With Application
If Not booOn Then AltCalc = .Calculation
.ScreenUpdating = booOn
.EnableEvents = booOn
.Calculation = IIf(booOn, AltCalc, xlCalculationManual)
End With
End Sub
Gruß Tino