auch das lässt sich abfangen, allerdings kommt der Fehler nicht weil der Ordner schon existiert, sondern weil du nicht die entsprechenden Rechte besitzt.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Sub copyDir()
Dim objFSO As Object, objFolder As Object, objSubFolder As Object, objFile As Object
Dim lngRet As Long
Dim strSourceDir As String, strTargetDir As String
Dim intModus As Integer
On Error GoTo ErrExit
strSourceDir = Range("A1").Text
strSourceDir = IIf(Right(strSourceDir, 1) = "\", Left(strSourceDir, Len(strSourceDir) - 1), strSourceDir)
strTargetDir = Range("B1").Text
strTargetDir = IIf(Right(strTargetDir, 1) = "\", strTargetDir, strTargetDir & "\")
intModus = Range("C1")
If Dir(strSourceDir, vbDirectory) = "" Then
MsgBox "Das Quellverzeichnis existiert nicht!", vbInformation, "Hinweis"
Exit Sub
End If
lngRet = MakeSureDirectoryPathExists(strTargetDir)
If lngRet = 0 Then
MsgBox "Das Zielverzeichnis existiert nicht und kann auch nicht erstellt werden!", vbInformation, "Hinweis"
Exit Sub
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Do
lngRet = objFSO.CopyFolder(strSourceDir, strTargetDir, True)
If Err.Number = 70 Then
Err.Clear
strTargetDir = strTargetDir & Mid(strSourceDir, InStrRev(strSourceDir, "\") + 1) & _
"_" & Format(Now, "yyyyMMddhhmmss") & "\"
MakeSureDirectoryPathExists strTargetDir
ElseIf Err.Number <> 0 Then
GoTo ErrExit
End If
Loop While lngRet <> 0
On Error GoTo ErrExit
If intModus = 0 Then
Set objFolder = objFSO.GetFolder(strTargetDir & Mid(strSourceDir, InStrRev(strSourceDir, "\") + 1))
For Each objSubFolder In objFolder.Subfolders
objFSO.DeleteFolder objSubFolder.Path, True
Next
ElseIf intModus = 1 Then
Set objFolder = objFSO.GetFolder(strTargetDir & Mid(strSourceDir, InStrRev(strSourceDir, "\") + 1))
For Each objSubFolder In objFolder.Subfolders
For Each objFile In objSubFolder.Files
objFSO.DeleteFile objFile.Path, True
Next
Next
End If
ErrExit:
If Err.Number <> 0 Then
MsgBox "Fehler beim Kopieren des Verzeicnises!" & vbLf & vbLf & Err.Number & vbLf & Err.Description, vbExclamation, "Hinweis"
End If
Set objFSO = Nothing
Set objFolder = Nothing
End Sub