Doppelt mit Fehler ;-((
10.05.2010 23:59:18
Josef
Hallo Markus,
da hat sich noch ein Fehler eingeschlichen.
Jetzt sollte es aber laufen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub backup()
Dim strSrcPath As String, strTgtPath As String, strFolder As String, strNewPath As String
Dim objFiles() As Object, objFSO As Object
Dim datMinDate As Date, datMaxDate As Date, datDate As Date
Dim lngRet As Long, lngIndex As Long, lngMonth As Long
strSrcPath = "E:\forum" 'Quellverzeichnis - Anpassen!
strTgtPath = "E:\Temp\Test\" 'Zielverzeichnis - Anpassen!
strTgtPath = IIf(Right(strTgtPath, 1) <> "\", strTgtPath & "\", strTgtPath)
lngMonth = Application.InputBox("Bitte gewünschtes Monat angeben:" & vbLf & _
"(1 = Januar, 2 = Februar, ... 12 = Dezember)", "Monat wählen", Month(Date), Type:=1)
If lngMonth = 0 Or lngMonth > 12 Then
MsgBox "Ungültige Monatsangabe, der Vorgang wird abgebrochen!", vbInformation, "Hinweis"
Exit Sub
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
datDate = DateSerial(Year(Date), lngMonth, 1)
datMinDate = DateSerial(Year(datDate), Month(datDate) - 1, 27)
datMaxDate = DateSerial(Year(datDate), Month(datDate) + 1, 1)
strFolder = strTgtPath & Format(datDate, "mmmmyy")
MakeSureDirectoryPathExists strFolder
lngRet = FileSearchINFO(objFiles, strSrcPath, SubFolders:=True)
If lngRet > 0 Then
For lngIndex = 0 To lngRet - 1
With objFiles(lngIndex)
If .datecreated >= datMinDate And .datecreated <= datMaxDate Then
strNewPath = Mid(.Path, Len(strSrcPath) + 1)
strNewPath = IIf(Left(strNewPath, 1) <> "\", "\" & strNewPath, strNewPath)
MakeSureDirectoryPathExists strFolder & strNewPath
objFSO.CopyFile objFiles(lngIndex), strFolder & strNewPath
End If
End With
Next
End If
Set objFSO = Nothing
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Gruß Sepp