Solved Rename and Move Files to a Folder in Bulk

arnelgp said:
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.
Click to expand...
so, means it's not possible to exclude the items already with prefix. better to leave this condition?
 
i added another parameter (secondRename).
you pass True to this parameter, so it will strip the
"prefix/suffix" we put on the first rename.
then compare it.

to call it (without adding suffix):

fncRenameFiles "d:\folder", , , "yourPrefix", "", True
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 = "", _
                        Optional ByVal secondRename As Boolean = False)
' 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
Dim bolOK As Boolean
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
If Right$(theSourcePath, 1) <> "\" Then
    theSourcePath = theSourcePath & "\"
End If
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 secondRename Then
        sName = Mid$(sName, Len(prefix) + 1)
        If Len(suffix) <> 0 Then
            sName = Left$(sName, Len(sName) - Len(suffix))
        End If
      End If
      bolOK = Len(Dir$(theSourcePath & prefix & sName & suffix & "." & sExt)) = 0
      If bolOK Then
         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
 
arnelgp said:
i added another parameter (secondRename).
you pass True to this parameter, so it will strip the
"prefix/suffix" we put on the first rename.
then compare it.

to call it (without adding suffix):

fncRenameFiles "d:\folder", , , "yourPrefix", "", True
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 = "", _
                        Optional ByVal secondRename As Boolean = False)
' 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
Dim bolOK As Boolean
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
If Right$(theSourcePath, 1) <> "\" Then
    theSourcePath = theSourcePath & "\"
End If
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 secondRename Then
        sName = Mid$(sName, Len(prefix) + 1)
        If Len(suffix) <> 0 Then
            sName = Left$(sName, Len(sName) - Len(suffix))
        End If
      End If
      bolOK = Len(Dir$(theSourcePath & prefix & sName & suffix & "." & sExt)) = 0
      If bolOK Then
         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
Click to expand...

It works the intended way. However, strips some of the characters in the first part of the file after renaming which had no prefix. In the below example, characters "test file" stripped for the file which didn't have the prefix.

Before:
1629965068440.png


After:
1629965125657.png
 
here check and test again.
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 = "", _
                        Optional ByVal secondRename As Boolean = False)
' 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
Dim bolOK As Boolean, sTemp As String
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
If Right$(theSourcePath, 1) <> "\" Then
    theSourcePath = theSourcePath & "\"
End If
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
      '
      sTemp = sName
      If secondRename Then
        sTemp = Mid$(sTemp, Len(prefix) + 1)
        If Len(suffix) <> 0 Then
            sTemp = Left$(sTemp, Len(sTemp) - Len(suffix))
        End If
      End If
      bolOK = Len(Dir$(theSourcePath & prefix & sTemp & suffix & "." & sExt)) = 0
      If bolOK Then
         Name theSourcePath & col(i) As (theSourcePath & prefix & sName & suffix & "." & sExt)
      End If
Next
'Msgbox "Done Renaming."
End Function
 
arnelgp said:
here check and test again.
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 = "", _
                        Optional ByVal secondRename As Boolean = False)
' 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
Dim bolOK As Boolean, sTemp As String
' if nothing to do exit sub
If Len(prefix) = 0 And Len(suffix) = 0 Then
      Exit Function
End If
If Right$(theSourcePath, 1) <> "\" Then
    theSourcePath = theSourcePath & "\"
End If
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
      '
      sTemp = sName
      If secondRename Then
        sTemp = Mid$(sTemp, Len(prefix) + 1)
        If Len(suffix) <> 0 Then
            sTemp = Left$(sTemp, Len(sTemp) - Len(suffix))
        End If
      End If
      bolOK = Len(Dir$(theSourcePath & prefix & sTemp & suffix & "." & sExt)) = 0
      If bolOK Then
         Name theSourcePath & col(i) As (theSourcePath & prefix & sName & suffix & "." & sExt)
      End If
Next
'Msgbox "Done Renaming."
End Function
Click to expand...
It worked like a magic wand. Thank you for helping. You are a star.
 
You must log in or register to reply here.

Similar threads

P
rename file
Replies
2
Views
232
theDBguy
theDBguy
J
VB Script: vbs to move selected files and folders in the current folder to a new custom folder by input box
Replies
11
Views
408
Isaac
Isaac
P
Loop through folder and save as Txt
Replies
10
Views
315
The_Doc_Man
The_Doc_Man
N
Solved Copy files from Network to a local folder based on last import
Replies
2
Views
187
Number11
N
NickCoe(UK)
Getting the true location of VBA reference files in 365 ctr.
Replies
17
Views
307
NickCoe(UK)
NickCoe(UK)

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom