AW: Dateinamen einlesen
02.08.2007 10:50:00
Tito
Mann so einfach! Danke!
Geht das eventuell auch bei dieser Funktion:
Option Explicit
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pIDList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Dim Verzeichnisse()
Dim Dateien()
Dim Anzdateien As Long
Sub Einlesen()
Dim Ordnername
Dim Pfad1 As String
Dim Obergrenze As Long
Dim Anzordner As Long
Dim i As Long
Const cVerzeichnistiefe = 1
Dim intVerzeichnistiefe As Integer
Dim Start As Long
Ordnername = "D:\Daten"
If Ordnername = False Then Exit Sub
ChDir Ordnername
'Wir gehen eine Ebene nach oben, damit wir von dort in dieses erste Verzeichnis wechseln können
ChDir ".."
If Ordnername "" Then
Anzdateien = 0
intVerzeichnistiefe = 0
Pfad1 = Ordnername 'Arbeitspfad merken
If Right(Ordnername, 1) "\" Then Pfad1 = Pfad1 & "\"
ReDim Verzeichnisse(0) 'Die Hauptebene wird das 0. Element
Verzeichnisse(0) = Pfad1
Obergrenze = UBound(Verzeichnisse)
ReDim Dateien(0)
Rekursion:
For i = Start To Obergrenze
Verzeichnisse_suchen Verzeichnisse(i), Obergrenze
intVerzeichnistiefe = intVerzeichnistiefe + 1
Start = Start + 1
Obergrenze = UBound(Verzeichnisse)
If intVerzeichnistiefe
intVerzeichnistiefe = intVerzeichnistiefe - 1
Next
Anzordner = Obergrenze + 1 'Für Anzeige; da Array mit 0 beginnt, 1 dazu
'War die Dateisuche erfolglos?
If Anzordner = 0 Then
MsgBox "Es gibt nichts zu tun!", vbInformation + vbOKOnly, "Keine Ordner"
Else
For i = 0 To Anzordner - 1
Cells(i + 1, 1).Value = Verzeichnisse(i)
Next
End If
End If
End Sub
Private Sub Verzeichnisse_suchen(ByVal Pfad As String, ByVal Arraygrenze As Long)
Dim Name1 As String
Name1 = Dir(Pfad, vbDirectory) ' Ersten Eintrag abrufen.
Do While Name1 "" ' Schleife beginnen.
' Aktuelles und übergeordnetes Verzeichnis ignorieren.
If Name1 "." And Name1 ".." Then
'Ist die gefundene Datei ein Verzeichnis?
If (GetAttr(Pfad & Name1) And vbDirectory) = vbDirectory Then
Arraygrenze = Arraygrenze + 1
ReDim Preserve Verzeichnisse(Arraygrenze)
Verzeichnisse(Arraygrenze) = Pfad & Name1 & "\"
End If
End If
Name1 = Dir 'Nächstes Verzeichnis finden
Loop
End Sub
Private Function Ordnerwählen(ByVal strTitle As String) As String
'Stellt ein Windows-Dialogfeld zur Verfügung, mit dem sich ein beliebiger Ordner auswählen läßt. _
'Entweder wird dieser oder (bei Abbruch) "" zurückgeliefert.
Dim lngIDList As Long
Dim strBuffer As String
Dim UserBrowseInfo As BrowseInfo
With UserBrowseInfo
.hwndOwner = 0
.lpszTitle = lstrcat(strTitle, "")
.ulFlags = 3
End With
lngIDList = SHBrowseForFolder(UserBrowseInfo)
If (lngIDList) Then
strBuffer = Space(260)
SHGetPathFromIDList lngIDList, strBuffer
strBuffer = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
Ordnerwählen = strBuffer
End If
End Function
End Sub