I am trying to rename a set of pdf filenames in the form:
"Joe BLOGGS_3052023.pdf" or "Joe BLOGGS_31052023.pdf"
("FirstName SURNAME_dmmyy" or "FirstName SURNAME_ddmmyy").
The month is always two digits. Only the day can be either dd or d.
I need the output of the filename to be:
Joe BLOGGS_20230503.pdf or Joe BLOGGS_20230531.pdf
Sub test()
Dim myDir As String
myDir = "e:\Test\"
If Dir(myDir, vbDirectory) = "" Then
MsgBox "Folder not found"
Exit Sub
End If
SeachFiles myDir, "*.pdf"
End Sub
Private Sub SeachFiles(myDir, fn)
Dim fso As Object, myFolder As Object, myFile As Object
Dim temp As String, m As Object, NewName As String, OldName As String
Set fso = CreateObject("Scripting.FileSystemObject")
With CreateObject("VBScript.RegExp")
.Pattern = "(?:\D)(\d{1,2})(\d{1,2})(\d{4})(?:\D)"
.ignorecase = True
For Each myFile In fso.getfolder(myDir).Files
If myFile.Name Like fn Then
If .test(myFile.Name) Then
If Not IsFileOpen(myDir & "\" & myFile.Name) Then
Set m = .Execute(myFile.Name)(0)
temp = Format$(DateValue(m.submatches(2) & "/" & _
m.submatches(0) & "/" & m.submatches(1)), "yyyymmdd")
NewName = myDir & "\" & Application.Replace(myFile.Name, _
m.firstindex + 2, m.Length - 1, temp)
OldName = myDir & "\" & myFile.Name
Name OldName As NewName
Else
MsgBox "Can not process " & myFile.Name & _
vbLf & "Currently open"
End If
End If
End If
Next
For Each myFolder In fso.getfolder(myDir).subfolders
SeachFiles myFolder.Path, fn
Next
End With
End Sub
Function IsFileOpen(fName As String) As Boolean
Dim ff As Integer, errNum As Integer
On Error Resume Next
ff = FreeFile
Open fName For Input Lock Read As #ff
Close ff
errNum = Err
On Error GoTo 0
IsFileOpen = (errNum <> 0)
End Function
Here is my new code. It works BUT it looped through and did the first of 8 files twice. All the rest are fine. I don't know why it did one file again!!
'this function checks to see if a folder/file exists
Function FileFolderExists(sPathFile As String) As Boolean
FileFolderExists = False
On Error Resume Next
If Not Dir(sPathFile, vbDirectory) = vbNullString Then FileFolderExists = True
On Error GoTo 0
End Function 'FileFolderExists
Sub Macro1()
Dim text As String
Dim secresult, oneresult, tworesult, mresult, dresult As String
Dim finalresult As String
Dim first, testlen, datelen As Integer
Dim sFilePath As String
Dim sFileName As String
Dim prfx As String
Dim sufx As String
Dim oName As String
Dim nName As String
Dim lNum As Long
'Specify File Path from Input Screen
sFilePath = [Source]
sFilePath = Application.WorksheetFunction.Clean(Trim(sFilePath))
If sFilePath = vbNullString Then
MsgBox "Source folder must be entered" & vbLf & vbLf & _
"Unable to continue with rename", vbCritical + vbExclamation
GoTo QuickExit
End If
If InStr(Len(sFilePath), sFilePath, "\") = 0 Then sFilePath = sFilePath & "\"
If Not FileFolderExists(sFilePath) Then
MsgBox "The input folder does not appear to be valid" & vbLf & vbLf & _
"Unable to continue with rename", vbCritical + vbExclamation
GoTo QuickExit
End If
'Specify new suffix
sufx = ".pdf"
'Check for back slash
If Right(sFilePath, 1) <> "\" Then
sFilePath = sFilePath & "\"
End If
sFileName = Dir(sFilePath & "*.pdf")
lNum = 0 ' File Counter
' Loop through all PDF files in folder
Do While Len(sFileName) > 0
'Find length of File Name
testlen = Len(sFileName)
first = InStr(sFileName, "_")
datelen = testlen - first
If datelen = 12 Then
secresult = Mid(sFileName, first + 1, 8)
oneresult = Left(secresult, 4)
mresult = Right(oneresult, 2)
dresult = Left(oneresult, 2)
tworesult = Right(secresult, 4)
finalresult = tworesult & mresult & dresult
ElseIf datelen = 11 Then
secresult = Mid(sFileName, first + 1, 7)
oneresult = Left(secresult, 3)
mresult = Right(oneresult, 2)
dresult = Left(oneresult, 1)
tworesult = Right(secresult, 4)
finalresult = tworesult & mresult & "0" & dresult
End If
'Specify new prefix
prfx = Left(sFileName, first)
'Get full path and name of file
oName = sFilePath & sFileName
'Build new path and name
nName = sFilePath & prfx & finalresult & sufx
'Rename file
Name oName As nName
'Set the fileName to the next available file
sFileName = Dir
lNum = lNum + 1 ' Increment File Counter
Loop
MsgBox "File Renaming complete!" & vbLf & vbLf & lNum & " file/s renamed"
QuickExit:
End Sub
Whilst improving your VBA skills, can I suggest in the interim, the Windows OS task is more suited to a batch file like this :-
ren-_dmmyyyy-test.cmd
@echo off
cd /d "e:\test"
SETLOCAL ENABLEDELAYEDEXPANSION
for %%f in (*.pdf) do (
set "$OldName=%%f"
set "$y=!$OldName:~-8,-4!"
if "!$OldName:~-12,-8!" == "2023" (echo some files already renamed&&goto abort)
set "test=!$OldName:~-12,-11!"
if !test!==_ (
set "$mmdd=!$OldName:~-10,-8!0!$OldName:~-11,-10!"
echo ren "%%f" "!$OldName:~0,-12!_!$y!!$mmdd!.pdf"
) else (
set "$mmdd=!$OldName:~-10,-8!!$OldName:~-12,-10!"
echo ren "%%f" "!$OldName:~0,-13!_!$y!!$mmdd!.pdf"
)
)
:abort
cd /d "%~dp0"
Note the echo before the 2 ren lines, is so that you can test, that it is what is required and if happy it solves an XY problem, then remove those 2 echo's.
based on above can be something like this
Private Sub SearchFiles(myDir, fn)
Dim fso As Object, myFolder As Object, myFile As Object
Dim temp As String, m As Object, NewName As String, OldName As String
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(myDir).Files
OldFile = myFile
temp$ = myFile.Name
Start$ = Left(temp$, Len(temp$) - 12)
ext = Right(temp$, 4)
yyyy = Left(Right(temp$, 8), 4)
dmm = Left(Right(temp$, 12), 4)
If Left(dmm, 1) = "_" Then
MsgBox "Name " & OldFile & " As " & Start$ & "_" & yyyy & Right(dmm, 2) & "0" & Mid(dmm, 2, 1) & ext
Else
MsgBox "Name " & OldFile & " As " & Start$ & yyyy & Right(dmm, 2) & Left(dmm, 2) & ext
End If
Next
End Sub
If happy that is what is wanted adjust the last two actions by remove MsgBox " and edit command to Name &" "& etc.