Re: Dateien in Excel Katalogisieren
02.05.2002 16:03:10
GraFri
Hallo--------------------------------------------------------
'Verzeichnis selektieren, auslesen und in Tabelle schreiben
' -----------------------------------------------------------------------------------
' Dieser Bereich kann entfallen, wenn der Variable 'strLaufwerk'
' ein fester Wert zugewiesen wird.
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
' -----------------------------------------------------------------------------------
Private sngZ As Single
' Hauptprogramm
Sub Suchen()
Dim strLaufwerk As String, strDateien As String
' Erste Zeile, in der eine Eintragung erfolgt
sngZ = 2
' Alte Eintragungen löschen
Columns("A:E") = ""
' Den Variablen strLaufwerk und strDateien kann
' auch ein direkter Wert zugewiesen werden.
' Ersatz: ... = "C:\Eigene strDateien"
strLaufwerk = GetDirectory("Bitte einen Ordner wählen")
If strLaufwerk = "" Then Exit Sub
' Ersatz: strDateien = "*.*"
strDateien = InputBox("Nach welchen Dateien soll in" & _
Chr(10) & " " & strLaufwerk & Chr(10) & _
"gesucht werden (sng z.B. *.xls)?", _
"Dateityp", "*.*")
If strDateien = "" Then Exit Sub
Dateisuche strLaufwerk, strDateien
End Sub
Sub Dateisuche(strLaufwerk, strDateien)
Dim tmp, Wdhlg, strDateiname As String
On Error Resume Next
If Right(strLaufwerk, 1) <> "\" Then strLaufwerk = strLaufwerk + "\"
tmp = Dir(strLaufwerk & strDateien)
Do While Len(tmp)
strDateiname = strLaufwerk & tmp
Application.StatusBar = strDateiname
Cells(sngZ, 1).Select
Cells(sngZ, 1) = strLaufwerk & tmp 'Pfad
Cells(sngZ, 2) = FileLen(strLaufwerk & tmp) 'Größe
Cells(sngZ, 3) = FileDateTime(strLaufwerk & tmp) 'Datum/Zeit
Cells(sngZ, 4) = tmp 'nur Dateiname
sngZ = sngZ + 1
tmp = Dir()
Loop
tmp = Dir(strLaufwerk, vbDirectory)
Do While Len(tmp)
If (tmp <> ".") And (tmp <> "..") Then
If (GetAttr(strLaufwerk & tmp) And vbDirectory) = vbDirectory Then
Dateisuche strLaufwerk & tmp, strDateien
sngZ = sngZ - 1
Wdhlg = Dir(strLaufwerk, vbDirectory)
sngZ = sngZ + 1
Do While Wdhlg <> tmp
Wdhlg = Dir()
Loop
End If
End If
tmp = Dir()
Loop
On Error GoTo 0
Application.StatusBar = False
End Sub
'//Datei, DLG csv-Datei öffnen//
' Öffnen-Dialog aufrufen, Auswahl: csv-Dateien
Sub MachAuf()
Datei = Application.GetOpenFilename("CSV-Dateien (*.csv), *.csv")
If Datei <> "Falsch" Then Workbooks.Open Filename:=Datei
End Sub
'//Datei, Dateien verschieben//
Dim strZielordner As String
' Aufruf mit dem folgenden Makro
Sub VerschiebeDateien()
Dim strHerkunftsordner As String, strDateienSuchstring As String
strZielordner = "C:\Eigene Dateien\Test\"
strHerkunftsordner = "C:\Eigene Dateien"
strDateienSuchstring = "*.xls"
Call DateienSuchenKopierenLöschen(strHerkunftsordner, strDateienSuchstring)
End Sub
' Ist verantwortlich für das Durchsuchen des Ordners und das Kopieren der Dateien
Sub DateienSuchenKopierenLöschen(strHerkunftsordner, strDateienSuchstring)
Dim strTmp As String, strWdhlg, strDateiname As String
' On Error Resume Next
If Right(strHerkunftsordner, 1) <> "\" Then strHerkunftsordner = strHerkunftsordner + "\"
' Erste Suche mit Dir() muss das Argument Fullname enthalten, Platzhalter * und ? werden unterstützt
strTmp = Dir(strHerkunftsordner & strDateienSuchstring)
' solange den Vorgaben in strDateienSuchstring (z.B. *.xls)
' eine entsprechende Datei gefunden wird
Do While Len(strTmp)
strDateiname = strHerkunftsordner & strTmp
Application.StatusBar = strDateiname
FileCopy strHerkunftsordner & strTmp, strZielordner & strTmp
Kill strHerkunftsordner & strTmp
' Die nächste den Vorgaben in strDateienSuchstring (z.B. *.xls) entsprechende Datei wird ohne
' Argumente gesucht, Dir() gibt dann eine Null-Zeichenfolge ("") zurück, wenn keine weitere Datei gefunden wird.
strTmp = Dir()
Loop
' Hier wird der Herkunftsordner auf Unterordner abgefragt und, falls vorhanden, miteinbezogen..
' Das gibt dann Probleme, wenn der Zielordner ein Unterordner vom Herkunftsordner ist.
' strTmp = Dir(strHerkunftsordner, vbDirectory)
' Do While Len(strTmp)
' If (strTmp <> ".") And (strTmp <> "..") Then
' If (GetAttr(strHerkunftsordner & strTmp) And vbDirectory) = vbDirectory Then
' DateienSuchenKopierenLöschen strHerkunftsordner & strTmp, strDateienSuchstring
' strWdhlg = Dir(strHerkunftsordner, vbDirectory)
' Do While strWdhlg <> strTmp
' strWdhlg = Dir()
' Loop
' End If
' End If
' strTmp = Dir()
' Loop
' On Error GoTo 0
Application.StatusBar = False
End Sub
' Ruft das Dialogfeld zur Ordnerauswahl auf (deaktiviert)
Function GetDirectory(Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
With bInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
' Funktion mit "shell32.dll"
x = SHBrowseForFolder(bInfo)
path = Space$(512)
' Funktion mit "shell32.dll"
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
--------------------------------------------------------mfg, GraFri