Solved Check File Exists and move files to other folder - paste, replace and append files (1 Viewer)

jack555

Member
Local time
Today, 05:50
Joined
Apr 20, 2020
Messages
47
I tried looking at multiple places, but could not file specific information.

How to find a file if exists without specifying file extension (like .pdf, .txt). Tried the below code found in this forum but an extension is required.

Code:
If Dir("C:\YourFile.xml") = "" then
     msgbox "file does not exist"
Else
     msgbox "file does exist"
End If

My objective is to move files from one folder to another. if the target folder having the same file name (irrespective of file type extension), it should paste the file with a slightly different name like name1 or name 2.

Kindly help. if somewhere already the solution exits, please refer me with a link. I tried hard in many ways.
 

arnelgp

error reading drive A:
Local time
Today, 09:50
Joined
May 7, 2009
Messages
12,080
Code:
If Dir$("C:\YourFile.*") = "" then
     msgbox "file does not exist"
Else
     msgbox "file does exist"
End If
 

jack555

Member
Local time
Today, 05:50
Joined
Apr 20, 2020
Messages
47
Code:
If Dir$("C:\YourFile.*") = "" then
     msgbox "file does not exist"
Else
     msgbox "file does exist"
End If

Thank you arnelgp. you are always helping me.

following this would like to ask your help how to paste the file with a new name (to add some suffix) if already exists in that folder. I have code to move but only moving if the file doesn't exist in the destination. which function to use. thanks in advance.
 

arnelgp

error reading drive A:
Local time
Today, 09:50
Joined
May 7, 2009
Messages
12,080
i made a function that will move your files.
copy and paste to New Module.
Code:
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)
'
' 3. 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 & "\", "\\", "\")
'* 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
   
    '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
 

jack555

Member
Local time
Today, 05:50
Joined
Apr 20, 2020
Messages
47
i made a function that will move your files.
copy and paste to New Module.
Code:
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)
'
' 3. 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 & "\", "\\", "\")
'* 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
  
    '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
Thank you for taking the time to support me. below error appeared. anything to add?


1610362074757.png
 

Gasman

Enthusiastic Amateur
Local time
Today, 02:50
Joined
Sep 21, 2011
Messages
7,906
Missing a Next ?
Possibly after the End Select ?
 

jack555

Member
Local time
Today, 05:50
Joined
Apr 20, 2020
Messages
47
Thank you, Gasman. I added a "Next" immediately after "End Select", code compiled successfully. however no action happened still, the files are in the folder not moved. I don't know where I am making mistake. Hope experts here could guide me.

copied the code into a module and only changed the file path; then called the procedure under on click event.
 

Gasman

Enthusiastic Amateur
Local time
Today, 02:50
Joined
Sep 21, 2011
Messages
7,906
You need to walk through the code with F8 and see what happens.?
 

arnelgp

error reading drive A:
Local time
Today, 09:50
Joined
May 7, 2009
Messages
12,080
i fix the problem (missing Next).
also, the function will not copy sub-folder and sub-folder files.
Code:
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
 

jack555

Member
Local time
Today, 05:50
Joined
Apr 20, 2020
Messages
47
i fix the problem (missing Next).
also, the function will not copy sub-folder and sub-folder files.
Code:
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

Thank you arnelgp. You saved my day, (maybe this year). Now the code works as intended. However one peculiar thing I noted after executing this.

1st instance it moves the file correctly. while at subsequent attempts somewhere the file name misses the ".", so the file is not readable. Maybe a small tweak will solve this problem, I couldn't fix myself. Thanks in advance.

1610423432133.png
 

arnelgp

error reading drive A:
Local time
Today, 09:50
Joined
May 7, 2009
Messages
12,080
i forgot to add the ".".
here is the fix:
Code:
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
        Loops
        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
 
Last edited:

jack555

Member
Local time
Today, 05:50
Joined
Apr 20, 2020
Messages
47
i forgot to add the ".".
here is the fix:
Code:
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
        Loops
        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

Thank you for solving the problem I had. Much appreciated. I will update the header of this thread to reflect appropriately.
 

Users who are viewing this thread

Top Bottom