Solved Rename and Move Files to a Folder in Bulk (1 Viewer)

jack555

Member
Local time
Today, 15:07
Joined
Apr 20, 2020
Messages
93
Having few files with different extensions (pdf, doc etc) in a folder. Below sequence to be achieved.

  • rename all the files in the source folder. as Me.textName with a random suffix for multiple files but all names should start with Me.textName without affecting the file type (random suffix like alphanumeric or timestamp whatever)
  • Check subfolder with name Me.txtName exists under "c:\\ToFolder". If not create a subfolder with name Me.txtName under "c:\\ToFolder"
  • Then move all files to the destination folder "c:\\ToFolder\me.txtname\".
  • if any of the file names exist, add the file with a series instead of replacing it. The filename should contain Me.txtName as a prefix, suffix doesn't matter may be random alphanumeric or timestamp whatever.
  • In summary, have to move all the files from the temporary folder to destination folder "c:\\ToFolder\Me.txtName". rename the file to series if filename already exists.

Earlier I have received support from arnelgp for moving the files without replacing. However, I realised that the renaming file has to be done which I am struggling now.

Please assist. Hope I stated the problem clearly.

https://www.access-programmers.co.u...-replace-and-append-files.315616/post-1741337
 

The_Doc_Man

Immoderate Moderator
Staff member
Local time
Today, 06:07
Joined
Feb 28, 2001
Messages
26,996
"In bulk" with a common prefix is doable, but not in a single operation. You would need a loop to do one file at a time. Now, a single action on your part surely could trigger this, but there would be no single command.

I would recommend the FileSystemObject as a major component of this initiative.


You can, in essence, get a collection of files that are in a given folder. Step through the files one at a time and test the name to match your template. Then, for matching names, use MoveFile or the VBA "NameAs" verb. Loop until you find no more files in that folder.
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 19:07
Joined
May 7, 2009
Messages
19,169
why not just Prefix the files with Me.textName, so the files will become:

strNewFileName = Me!TextName & theOriginalFilename + extension

Rename the files first, then Move them using the previous function i gave.
Code:
Public Function fncRenameFiles(ByVal theSourcePath As String, _
                        Optional ByVal theFile As String = "*", _
                        Optional ByVal theExtension As String = "*", _
                        Optional ByVal prefix As String = "", _
                        Optional ByVal suffix As String = "")
' Note:
'
' not much validation on this function, so:
'
' don't add extension (.bat, .xlsx, etc) to "theFile"
' don't ad "." to the "theExtension (simply "bat" or "xlsx")
'
' theSourcePath must be valid path
'
' make sure none of the Files to be renamed are opened
' by another program.
'
Dim sFile As String
Dim col As New Collection
Dim i As Integer
Dim sName As String, sExt As String
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
theSourcePath = Replace$(theSourcePath & "\", "\\", "\")
sFile = Dir$(theSourcePath & theFile & theExtension)
'put all files in collection
Do Until Len(sFile) = 0
      col.Add theSourcePath & sFile
      sFile = Dir$
Loop
'rename files in collection
For i = 1 To col.Count
      sName = Replace$(thisFileName(col(i)), theSourcePath, vbNullString)
      sExt = thisExtension(col(i))
      'Debug.Print col(i), theSourcePath & prefix & sName & suffix & "." & sExt
      Name col(i) As (theSourcePath & prefix & sName & suffix & "." & sExt)
Next
'Msgbox "Done Renaming."
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
 
Last edited:

jack555

Member
Local time
Today, 15:07
Joined
Apr 20, 2020
Messages
93
why not just Prefix the files with Me.textName, so the files will become:

strNewFileName = Me!TextName & theOriginalFilename + extension

Rename the files first, then Move them using the previous function i gave.
Code:
Public Function fncRenameFiles(ByVal theSourcePath As String, _
                        Optional ByVal theFile As String = "*", _
                        Optional ByVal theExtension As String = "*", _
                        Optional ByVal prefix As String = "", _
                        Optional ByVal suffix As String = "")
' Note:
'
' not much validation on this function, so:
'
' don't add extension (.bat, .xlsx, etc) to "theFile"
' don't ad "." to the "theExtension (simply "bat" or "xlsx")
'
' theSourcePath must be valid path
'
' make sure none of the Files to be renamed are opened
' by another program.
'
Dim sFile As String
Dim col As New Collection
Dim i As Integer
Dim sName As String, sExt As String
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
theSourcePath = Replace$(theSourcePath & "\", "\\", "\")
sFile = Dir$(theSourcePath & theFile & theExtension)
'put all files in collection
Do Until Len(sFile) = 0
      col.Add theSourcePath & sFile
      sFile = Dir$
Loop
'rename files in collection
For i = 1 To col.Count
      sName = Replace$(thisFileName(col(i)), theSourcePath, vbNullString)
      sExt = thisExtension(col(i))
      'Debug.Print col(i), theSourcePath & prefix & sName & suffix & "." & sExt
      Name col(i) As (theSourcePath & prefix & sName & suffix & "." & sExt)
Next
'Msgbox "Done Renaming."
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 the live saving support always. while calling this function, got the error "argument not optional" as below. dont know how to resolve it.

1610867940488.png
 

jack555

Member
Local time
Today, 15:07
Joined
Apr 20, 2020
Messages
93
"In bulk" with a common prefix is doable, but not in a single operation. You would need a loop to do one file at a time. Now, a single action on your part surely could trigger this, but there would be no single command.

I would recommend the FileSystemObject as a major component of this initiative.


You can, in essence, get a collection of files that are in a given folder. Step through the files one at a time and test the name to match your template. Then, for matching names, use MoveFile or the VBA "NameAs" verb. Loop until you find no more files in that folder.
Thank you, Doc. I will start learning about FileSystemObject.
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 19:07
Joined
May 7, 2009
Messages
19,169
Code:
Private Sub command5_Click()
    Call fncRenameFiles("D:\thePathOftheFilesToRename", , , Me!TextboxName & "_")
End Sub
 

jack555

Member
Local time
Today, 15:07
Joined
Apr 20, 2020
Messages
93
Thank you arnelgp for solving this problem. Always you post detailed code which is really helpful for the beginners and non coders. much appreciated.
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 19:07
Joined
May 7, 2009
Messages
19,169
you're welcome :)
 

jack555

Member
Local time
Today, 15:07
Joined
Apr 20, 2020
Messages
93
Hi arnelgp,

Again have to come back on how to solve a specific problem arising from the usage of the above functions. File rename and moving work fine if the folder location is named starting like "G:", "K:", "C:". However, if the location is on a network location starting like "\\ADX123\Global\samplefolder" the code stops working and does nothing.

Is there any way we can overcome this limitation? this project is based on the folders in the network only. thanks in advance.
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 19:07
Joined
May 7, 2009
Messages
19,169
check and test if this will work for you.
replace all my code with this one.
Code:
Public Function fncRenameFiles(ByVal theSourcePath As String, _
                        Optional ByVal theFile As String = "*", _
                        Optional ByVal theExtension As String = "*", _
                        Optional ByVal prefix As String = "", _
                        Optional ByVal suffix As String = "")
' Note:
'
' not much validation on this function, so:
'
' don't add extension (.bat, .xlsx, etc) to "theFile"
' don't ad "." to the "theExtension (simply "bat" or "xlsx")
'
' theSourcePath must be valid path
'
' make sure none of the Files to be renamed are opened
' by another program.
'
Dim sFile As String
Dim col As New Collection
Dim i As Integer
Dim sName As String, sExt As String
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If

' 16-feb-2021
' on unc path, you can't do this
'theSourcePath = Replace$(theSourcePath & "\", "\\", "\")
If Right$(theSourcePath, 1) <> "\" Then theSourcePath = theSourcePath & "\"
' end of modification

sFile = Dir$(theSourcePath & theFile & theExtension)
'put all files in collection
Do Until Len(sFile) = 0
      col.Add theSourcePath & sFile
      sFile = Dir$
Loop
'rename files in collection
For i = 1 To col.Count
      sName = Replace$(thisFileName(col(i)), theSourcePath, vbNullString)
      sExt = thisExtension(col(i))
      'Debug.Print col(i), theSourcePath & prefix & sName & suffix & "." & sExt
      Name col(i) As (theSourcePath & prefix & sName & suffix & "." & sExt)
Next
'Msgbox "Done Renaming."
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, 15:07
Joined
Apr 20, 2020
Messages
93
Thank you now it successfully renames the network files. I tried to modify the below code for moving files in network location path with below code, it doesn't work. I think I miss something here. for your kind help.

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
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 19:07
Joined
May 7, 2009
Messages
19,169
test this one:
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)
'
' 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

' 17-feb-2021
' pSourceFolder = Replace$(pSourceFolder & "\", "\\", "\")
' pTargetFolder = Replace$(pTargetFolder & "\", "\\", "\")
'
If Right$(pSourceFolder, 1) <> "\" Then pSourceFolder = pSourceFolder & "\"
If Right$(pTargetFolder, 1) <> "\" Then pTargetFolder = pTargetFolder & "\"
'
' end of modification 17-feb-2021
'

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
 

jack555

Member
Local time
Today, 15:07
Joined
Apr 20, 2020
Messages
93
test this one:
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)
'
' 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

' 17-feb-2021
' pSourceFolder = Replace$(pSourceFolder & "\", "\\", "\")
' pTargetFolder = Replace$(pTargetFolder & "\", "\\", "\")
'
If Right$(pSourceFolder, 1) <> "\" Then pSourceFolder = pSourceFolder & "\"
If Right$(pTargetFolder, 1) <> "\" Then pTargetFolder = pTargetFolder & "\"
'
' end of modification 17-feb-2021
'

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. it worked like a charm. you are a star.
 

jack555

Member
Local time
Today, 15:07
Joined
Apr 20, 2020
Messages
93
why not just Prefix the files with Me.textName, so the files will become:

strNewFileName = Me!TextName & theOriginalFilename + extension

Rename the files first, then Move them using the previous function i gave.
Code:
Public Function fncRenameFiles(ByVal theSourcePath As String, _
                        Optional ByVal theFile As String = "*", _
                        Optional ByVal theExtension As String = "*", _
                        Optional ByVal prefix As String = "", _
                        Optional ByVal suffix As String = "")
' Note:
'
' not much validation on this function, so:
'
' don't add extension (.bat, .xlsx, etc) to "theFile"
' don't ad "." to the "theExtension (simply "bat" or "xlsx")
'
' theSourcePath must be valid path
'
' make sure none of the Files to be renamed are opened
' by another program.
'
Dim sFile As String
Dim col As New Collection
Dim i As Integer
Dim sName As String, sExt As String
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
theSourcePath = Replace$(theSourcePath & "\", "\\", "\")
sFile = Dir$(theSourcePath & theFile & theExtension)
'put all files in collection
Do Until Len(sFile) = 0
      col.Add theSourcePath & sFile
      sFile = Dir$
Loop
'rename files in collection
For i = 1 To col.Count
      sName = Replace$(thisFileName(col(i)), theSourcePath, vbNullString)
      sExt = thisExtension(col(i))
      'Debug.Print col(i), theSourcePath & prefix & sName & suffix & "." & sExt
      Name col(i) As (theSourcePath & prefix & sName & suffix & "." & sExt)
Next
'Msgbox "Done Renaming."
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
Hi arnelgp,

in this code provided earlier, how could we add an exception not to rename if a condition met. fncRenameFiles(FromPath, , , textName & "_"). If Me.txtName already exists in the file name then adding txtName as a prefix is not required. Kindly help if possible.
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 19:07
Joined
May 7, 2009
Messages
19,169
what is the condition?
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 19:07
Joined
May 7, 2009
Messages
19,169
i modified the Rename function (i think this is what you need to modify):
Code:
Public Function fncRenameFiles(ByVal theSourcePath As String, _
                        Optional ByVal theFile As String = "*", _
                        Optional ByVal theExtension As String = "*", _
                        Optional ByVal prefix As String = "", _
                        Optional ByVal suffix As String = "")
' Note:
'
' not much validation on this function, so:
'
' don't add extension (.bat, .xlsx, etc) to "theFile"
' don't ad "." to the "theExtension (simply "bat" or "xlsx")
'
' theSourcePath must be valid path
'
' make sure none of the Files to be renamed are opened
' by another program.
'
Dim sFile As String
Dim col As New Collection
Dim i As Integer
Dim sName As String, sExt As String
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
theSourcePath = Replace$(theSourcePath & "\", "\\", "\")
sFile = Dir$(theSourcePath & theFile & theExtension)
'put all files in collection
Do Until Len(sFile) = 0
      col.Add sFile
      sFile = Dir$
Loop
'rename files in collection
For i = 1 To col.Count
      sName = Replace$(thisFileName(col(i)), theSourcePath, vbNullString)
      sExt = thisExtension(col(i))
      'Debug.Print col(i), theSourcePath & prefix & sName & suffix & "." & sExt
      '
      'agp
      '25-aug-2021
      'do not rename if already exists
      '
      If Len(Dir$(theSourcePath & prefix & sName & suffix & "." & sExt)) <> 0 Then
         'do nothing
      Else
         Name theSourcePath & col(i) As (theSourcePath & prefix & sName & suffix & "." & sExt)
      End If
Next
'Msgbox "Done Renaming."
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, 15:07
Joined
Apr 20, 2020
Messages
93
i modified the Rename function (i think this is what you need to modify):
Code:
Public Function fncRenameFiles(ByVal theSourcePath As String, _
                        Optional ByVal theFile As String = "*", _
                        Optional ByVal theExtension As String = "*", _
                        Optional ByVal prefix As String = "", _
                        Optional ByVal suffix As String = "")
' Note:
'
' not much validation on this function, so:
'
' don't add extension (.bat, .xlsx, etc) to "theFile"
' don't ad "." to the "theExtension (simply "bat" or "xlsx")
'
' theSourcePath must be valid path
'
' make sure none of the Files to be renamed are opened
' by another program.
'
Dim sFile As String
Dim col As New Collection
Dim i As Integer
Dim sName As String, sExt As String
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
theSourcePath = Replace$(theSourcePath & "\", "\\", "\")
sFile = Dir$(theSourcePath & theFile & theExtension)
'put all files in collection
Do Until Len(sFile) = 0
      col.Add sFile
      sFile = Dir$
Loop
'rename files in collection
For i = 1 To col.Count
      sName = Replace$(thisFileName(col(i)), theSourcePath, vbNullString)
      sExt = thisExtension(col(i))
      'Debug.Print col(i), theSourcePath & prefix & sName & suffix & "." & sExt
      '
      'agp
      '25-aug-2021
      'do not rename if already exists
      '
      If Len(Dir$(theSourcePath & prefix & sName & suffix & "." & sExt)) <> 0 Then
         'do nothing
      Else
         Name theSourcePath & col(i) As (theSourcePath & prefix & sName & suffix & "." & sExt)
      End If
Next
'Msgbox "Done Renaming."
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
Tried running the code, but no change in the outcome. It renames all the files in the folder including the ones if the name already matches with prefix.
 

jack555

Member
Local time
Today, 15:07
Joined
Apr 20, 2020
Messages
93
i modified the Rename function (i think this is what you need to modify):
Code:
Public Function fncRenameFiles(ByVal theSourcePath As String, _
                        Optional ByVal theFile As String = "*", _
                        Optional ByVal theExtension As String = "*", _
                        Optional ByVal prefix As String = "", _
                        Optional ByVal suffix As String = "")
' Note:
'
' not much validation on this function, so:
'
' don't add extension (.bat, .xlsx, etc) to "theFile"
' don't ad "." to the "theExtension (simply "bat" or "xlsx")
'
' theSourcePath must be valid path
'
' make sure none of the Files to be renamed are opened
' by another program.
'
Dim sFile As String
Dim col As New Collection
Dim i As Integer
Dim sName As String, sExt As String
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
theSourcePath = Replace$(theSourcePath & "\", "\\", "\")
sFile = Dir$(theSourcePath & theFile & theExtension)
'put all files in collection
Do Until Len(sFile) = 0
      col.Add sFile
      sFile = Dir$
Loop
'rename files in collection
For i = 1 To col.Count
      sName = Replace$(thisFileName(col(i)), theSourcePath, vbNullString)
      sExt = thisExtension(col(i))
      'Debug.Print col(i), theSourcePath & prefix & sName & suffix & "." & sExt
      '
      'agp
      '25-aug-2021
      'do not rename if already exists
      '
      If Len(Dir$(theSourcePath & prefix & sName & suffix & "." & sExt)) <> 0 Then
         'do nothing
      Else
         Name theSourcePath & col(i) As (theSourcePath & prefix & sName & suffix & "." & sExt)
      End If
Next
'Msgbox "Done Renaming."
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
Hi @arnelgp I tried this code, but no change in action. It renames all irrespective of the prefix name already present or not. Kindly help.
 

arnelgp

..forever waiting... waiting for jellybean!
Local time
Today, 19:07
Joined
May 7, 2009
Messages
19,169
it will rename the files Again and Again, let me explain.

supposed there is a filename: x.txt
you run the function to rename it with prefix "1_"
the function will check if "1_x.txt" (prefix of "1_" + the filename) already exists.
it will not find, so it will be renamed as "1_x.txt"

you run the function again using same prefix of "1_"
the functon will check if "1_1_x.txt" exists, (remember that
we already renamed x.txt as 1_x.txt, adding another prefix of "1_",
we are now to look if prefix & filename, exists which is "1_" & "1_x.txt")
it will not find, so again it will rename it.
 

Users who are viewing this thread

Top Bottom