Option Explicit
Sub Copy_Files_To_New_Folder()
Dim objFSO As FileSystemObject, objFolder As Folder, PathExists As Boolean
Dim objFile As File, strSourceFolder As String, strDestFolder As String
Dim x, Counter As Integer, Overwrite As String
Application.ScreenUpdating = False
Application.EnableEvents = False
strSourceFolder = "C:\MyFolder"
strDestFolder = "C:\Backup"
On Error Resume Next
x = GetAttr(strDestFolder) And 0
If Err = 0 Then
PathExists = True
Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
"Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
If Overwrite <> vbYes Then Exit Sub
Else:
PathExists = False
If PathExists = False Then MkDir (strDestFolder)
End If
On Error GoTo ErrHandler
Set objFSO = New FileSystemObject
Set objFolder = objFSO.GetFolder(strSourceFolder)
Counter = 0
If Not objFolder.Files.Count > 0 Then GoTo NoFiles
For Each objFile In objFolder.Files
objFile.Copy strDestFolder & "\" & objFile.Name
Counter = Counter + 1
Next objFile
MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
" copied/moved to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing
Exit Sub
NoFiles:
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
"Please verify that all files in the folder are not currently open," & _
"and the source directory is available"
Err.Clear
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Sub Copy_and_Rename_To_New_Folder()
Dim objFSO As FileSystemObject, objFolder As Folder, PathExists As Boolean
Dim objFile As File, strSourceFolder As String, strDestFolder As String
Dim x, Counter As Integer, Overwrite As String, strNewFileName As String
Dim strName As String, strMid As String, strExt As String
Application.ScreenUpdating = False
Application.EnableEvents = False
strSourceFolder = "C:\MyFolder"
strDestFolder = "C:\Backup"
On Error Resume Next
x = GetAttr(strDestFolder) And 0
If Err = 0 Then
PathExists = True
Overwrite = MsgBox("The folder may contain duplicate files," & vbNewLine & _
"Do you wish to overwrite existing files with same name?", vbYesNo, "Alert!")
If Overwrite <> vbYes Then Exit Sub
Else:
PathExists = False
If PathExists = False Then MkDir (strDestFolder)
End If
On Error GoTo ErrHandler
Set objFSO = New FileSystemObject
Set objFolder = objFSO.GetFolder(strSourceFolder)
Counter = 0
If Not objFolder.Files.Count > 0 Then GoTo NoFiles
For Each objFile In objFolder.Files
strName = Left(objFile.Name, Len(objFile.Name) - 4)
strMid = Format(objFile.DateLastModified, "_mmm_dd_yy")
strExt = Right(objFile.Name, 4)
strNewFileName = strName & strMid & strExt
objFile.Copy strDestFolder & "\" & strNewFileName
Counter = Counter + 1
Next objFile
MsgBox "All " & Counter & " Files from " & vbCrLf & vbCrLf & strSourceFolder & vbNewLine & vbNewLine & _
" copied/moved to: " & vbCrLf & vbCrLf & strDestFolder, , "Completed Transfer/Copy!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing
Exit Sub
NoFiles:
MsgBox "There Are no files or documents in : " & vbNewLine & vbNewLine & _
strSourceFolder & vbNewLine & vbNewLine & "Please verify the path!", , "Alert: No Files Found!"
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
ErrHandler:
MsgBox "Error: " & Err.Number & Err.Description & vbCrLf & vbCrLf & vbCrLf & _
"Please verify that all files in the folder are not currently open," & _
"and the source directory is available"
Err.Clear
Set objFile = Nothing: Set objFSO = Nothing: Set objFolder = Nothing
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
|