"Backup- Makro"
03.07.2005 12:42:19
Torben
Hallo zusammen :)
Habe folgendes Makro gebastelt:
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
strSpeicherpfad As String
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
Function GetDirectory(Msg) As String
speicherpfad = pfad
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
x = SHBrowseForFolder(bInfo)
path = Space$(512)
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
Sub speichern()
o = InputBox("Name für Backup Ordner eingeben")
If o <> "" Then
Else: o = InputBox("Name für Backup Ordner eingeben")
Do
o = InputBox("Name für Backup Ordner eingeben")
If o <> "" Then Exit Do
Loop Until o <> ""
End If
s = GetDirectory("Bitte wählen sie den Ordner aus, in dem Backup erstellt werden soll")
If s <> "" Then
ChDir s
Else: MsgBox "Ordnerauswahl erforderlich"
Do
s = GetDirectory("Bitte wählen sie den Ordner aus, in dem Backup erstellt werden soll")
If s <> "" Then Exit Do
Loop Until s <> ""
End If
If Dir(o, 16) = o Then
MsgBox "Ordner bereits vorhanden"
Else: MkDir o
End If
t = GetDirectory("Verzeichnis der zu sichernden Dateien auswählen")
u = InputBox("Dateiendung angeben,z.B. *.xls")
'With Application.FileSearch
'.NewSearch
'.LookIn = t
'.Filename = dateiendung
'.SearchSubFolders = True
'.Execute
'MsgBox .FoundFiles.Count
'End With
ChDir t
x = t & "\" & u
y = s & "\" & o
Dim index As Integer, FSYObjekt As Object, FObjekt As Object
Set FSYObjekt = CreateObject("Scripting.FileSystemObject")
With Application.FileSearch
.Filename = u
.LookIn = t
.SearchSubFolders = True
If .Execute > 0 Then
For index = 1 To .FoundFiles.Count
Set FObjekt = FSYObjekt.GetFile(.FoundFiles(index))
If .FoundFiles.Count > 0 Then FObjekt.Move "y"
Next
End If
End With
End Sub
Es funktioniert auch alles bis auf den "Schluss" wenn er die Objekte kopieren soll, da scheitert er immer...kann mir jmnd erklären wie das geht, oder ggf. Code mit Kommentare (ich möchte gerne etwas lernen ).
Danke Euch allen ! Tolle Seite !