Option Compare Database
Option Explicit
Public Function fncMoveFiles(ByVal pSourceFolder As String, _
ByVal pTargetFolder As String, _
Optional ByVal pFileName As String = "*", _
Optional ByVal pExtension As String = "*", _
Optional ByVal pOption As Integer = 1)
' arnelgp
'
' pOption:
'
' 1 = do not copy if exists
' 2 = overwrite
' 3 = do not overwrite but create new (serial) file
'
' Examples:
'
' 1. move all files (*.*) from C:\Folder1 to D:\NewFolder
' without overwritting same file.
'
' Call fncMoveFiles("C:\Folder1", "D:\NewFolder")
'
' 2. move all files (*.*) from C:\Folder1 to D:\NewFolder
' overwritting same file.
'
' Call fncMoveFiles("C:\Folder1", "D:\NewFolder", , , 2)
'
' 2. move all files (*.*) from C:\Folder1 to D:\NewFolder
' renaming (serialize) same file.
'
' Call fncMoveFiles("C:\Folder1", "D:\NewFolder", , , 3)
'
Dim oSourceCol As New Collection
Dim oTargetCol As New Collection
Dim oToDelete As New Collection
Dim sFilePath As String, sTemp As String
Dim sTempF As String, sTempX As String
Dim i As Integer, j As Integer
'* remove the "." from the extension (if it is supplied)
If InStrRev(pExtension, ".") > 0 Then
pExtension = Mid$(pExtension, InStrRev(pExtension, ".") + 1)
End If
pSourceFolder = Replace$(pSourceFolder & "\", "\\", "\")
pTargetFolder = Replace$(pTargetFolder & "\", "\\", "\")
Call fncForceMKDir(pTargetFolder)
'* remove the extension from the pFileName
sFilePath = Dir$(pSourceFolder & fncFileNameOnly(pFileName) & "." & pExtension)
Do Until Len(sFilePath) = 0
oSourceCol.Add pSourceFolder & sFilePath
oTargetCol.Add pTargetFolder & sFilePath
sFilePath = Dir$()
Loop
For i = 1 To oSourceCol.Count
Select Case pOption
Case Is = 1
If Len(Dir$(oTargetCol(i))) > 0 Then
'do nothing (do not copy)
Else
FileCopy oSourceCol(i), oTargetCol(i)
oToDelete.Add i
End If
Case Is = 2
On Error Resume Next
Kill oTargetCol(i)
On Error GoTo 0
FileCopy oSourceCol(i), oTargetCol(i)
oToDelete.Add i
Case Is = 3
sTemp = oTargetCol(i)
j = 0
Do While Len(Dir$(sTemp)) > 0
j = j + 1
sTemp = oTargetCol(i)
sTempF = thisFileName(sTemp)
sTempF = sTempF & "(" & j & ")"
sTempX = thisExtension(sTemp)
sTemp = sTempF & sTempX
Loop
FileCopy oSourceCol(i), sTemp
oToDelete.Add i
End Select
Next
'delete the source
For i = 1 To oToDelete.Count
Kill oSourceCol(oToDelete(i))
Next
End Function
Public Function fncFileNameOnly(ByVal pFile As String) As String
With CreateObject("VBScript.RegExp")
.Global = False
.IgnoreCase = True
.Pattern = "^(\w+)(.*)(\..*)$"
fncFileNameOnly = .Replace(pFile, "$1$2")
End With
End Function
Private Function thisFileName(ByVal pFile) As String
Dim i As Integer
thisFileName = pFile
i = InStrRev(pFile, ".")
If i > 0 Then
thisFileName = Left(pFile, i - 1)
End If
End Function
Private Function thisExtension(ByVal pFile) As String
Dim i As Integer
thisExtension = pFile
i = InStrRev(pFile, ".")
If i > 0 Then
thisExtension = Mid(pFile, i + 1)
End If
End Function
Public Function fncForceMKDir(ByVal pPath As String)
Dim i As Integer
Dim var As Variant
Dim sPath As String
var = Split(pPath, "\")
On Error Resume Next
For i = LBound(var) To UBound(var)
sPath = sPath & var(i)
MkDir sPath
sPath = sPath & "\"
Next
End Function