Happy New Year!
Current code is # Sub RenameFiles()
'set variables
Dim a, i As Long, j As Long, fn$, fn2$, p$, fso As Object
If Range("B7") = 0 Then
MsgBox "No files captured! Please capture files.", vbCritical, "Rename files"
Else
a = aFFs(Range("C2"), , True)
If Not IsArray(a) Then Exit Sub
Set fso = CreateObject("Scripting.FileSystemObject")
For j = LBound(a) To UBound(a)
p = fso.GetParentFolderName(a(j)) & ""
fn = fso.GetFileName(a(j))
If InStr(fn, "_") > 0 Then
fn2 = p & Replace(fn, "_", " ")
'If InStr(fn, " ") > 0 Then
'fn2 = p & Replace(fn, " ", "_")
If Not IsFileOpen(CStr(a(j))) And Not fso.FileExists(fn2) Then
'Name a(j) As fn2
fso.MoveFile a(j), fn2
i = i + 1
Else 'in case of error
Debug.Print "Overwrite issue?", fn2
End If
End If
Next j
Select Case i
Case 0
MsgBox "No files were renamed!", vbCritical, "Rename Files"
Case 1
MsgBox "1 file was renamed", vbExclamation, "Rename Files"
Case Else
MsgBox i & " files renamed", vbExclamation, "Rename Files"
End Select
Set fso = Nothing
End If
End Sub
'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir,
http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant
Dim s As String, p As String, a() As String, v As Variant
Dim b() As Variant, i As Long, fso As Object
If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
Set fso = CreateObject("Scripting.FileSystemObject")
p = fso.GetParentFolderName(myDir) & ""
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If
a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
MsgBox myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, ""))
'add the folder name
a(i) = p & a(i)
End If
Next i
Set fso = Nothing
aFFs = sA1dtovA1d(a)
End Function
Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function
Function IsFileOpen(FileName As String)
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As
#iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select
End Function
Function IsWorkbookOpen(stName As String) As Boolean
Dim Wkb As Workbook
On Error Resume Next ' In Case it isn't Open
Set Wkb = Workbooks(stName)
If Not Wkb Is Nothing Then IsWorkbookOpen = True
'Boolean Function assumed To be False unless Set To True
End Function
Sub callrenamefiles()
CarryOn = MsgBox("Are you sure you wish to proceed with rename action?" & vbLf & vbLf & "This action is irreversible and will impact all files in selected path!", vbYesNo + vbExclamation, "Rename files")
If CarryOn = vbYes Then
Call RenameFiles
End If
End Sub#
Appreciated for your review and inputs why error 75 still pops up.
