VBA » File » Loop and Rename

Code

' http://msaccessgurus.com/VBA/Code/File_LoopRenameDate.htm
' bas_vba_File_LoopRename_s4p
'*************** Code Start *****************************************************
' Purpose  : Loop through files in a folder, rename with subject, date and time modified
' Author   : crystal (strive4peace)
' License  : below code
' Code List: www.MsAccessGurus.com/code.htm
'--------------------------------------------------------------------------------
'                              Module declaration
'--------------------------------------------------------------------------------
' --------- Scripting.FileSystemObject
Private moFile_fso As Object 
'--------------------------------------------------------------------------------
'                              RUN LoopFolder_RenameFiles
'--------------------------------------------------------------------------------
Sub run_LoopFolder_RenameFiles() 
'220102 strive4peace

   'CALLS
   '  LoopFolder_RenameFiles

   'CLICK HERE
   'Press F5 to Run!     ... after CUSTOMIZE!
   'turn on Immediate window to see results
   
   Dim sPath As String _ 
      ,sPrefix As String _ 
      ,sMsg As String 
      
   sPrefix =  "catSleep_"      '----------- CUSTOMIZE!
   sPath =  "E:\p\pic_catsSleep"    '----------- CUSTOMIZE!
   
   '~~~~~~~~~~~~~~~~~~~~~ Call LoopFolder_RenameFiles
   'Call LoopFolder_RenameFiles
   '  send sPath for path
   '  , true for SkipPromptEachFile
   '  , skip FormatCode and Mask so defaults will be used
   '  , specify prefix to be sPrefix
   '  , GET messageback
   'ignore function return for number of changed files
   Call LoopFolder_RenameFiles( _ 
      sPath,True,,,sPrefix,sMsg) 
   '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   
   Debug.Print sMsg 
   
   sMsg = sMsg & vbCrLf & vbCrLf &  "Open folder?"
   If MsgBox(sMsg,vbYesNo, "Done. Open Folder?") = vbYes Then 
      Call Shell( "Explorer.exe" &  " " & sPath,vbNormalFocus) 
   End If 
   
End Sub 
'--------------------------------------------------------------------------------
'                              LoopFolder_RenameFiles
'--------------------------------------------------------------------------------
Function LoopFolder_RenameFiles(psPath As String _ 
   ,Optional pBooSkipPromptEachFile As Boolean = True _ 
   ,Optional psFormatCode As String =  "yymmdd_ddd_hhnn" _ 
   ,Optional psMask As String =  "*.*" _ 
   ,Optional psPrefix As String =  "p" _ 
   ,Optional ByRef psRETURNMsg As String _ 
   ) As Integer 
' s4p 161005, 181207, 220101,2
   'PARAMETERS
   '   psPath is the path to use
   '   Optional:
   '   pBooSkipPromptEachFile, Boolean, Default = true
   '   psFormatCode, String, default = "yymmdd_ddd_hhnn"
   '   psMask, String, file specification to match. Default = "*.*"
   '   psPrefix, String, characters to put at beginning of filename. Default = "p" _
   '   psRETURNMsg, String, message to send back to calling program

   'CALLS
   '  GetArrayFilenames

   On Error GoTo proc_Err 
 
   Dim aFilename() As String 
   
   Dim iFile As Integer _ 
      ,iPos As Integer _ 
      ,iAnswer As Integer _ 
      ,iCount As Integer _ 
      ,iCountDone As Integer _ 
      ,sFilename As String _ 
      ,sAdjustedName As String _ 
      ,sNewFilename As String _ 
      ,sPathFile As String _ 
      ,sExtraInfo As String _ 
      ,sNewPathFile As String _ 
      ,sSeparator As String _ 
      ,sMsg As String _ 
      ,booDo As Boolean 
      
   sSeparator =  "~-"

   If Right(psPath,1) <>  "\" Then 
      psPath = Trim(psPath) &  "\"
   End If 
   
   iCount = 0 
   iCountDone = 0 

   '---------------------------- array of filenames
   aFilename = GetArrayFilenames(psPath,psMask) 
   
   For iFile = LBound(aFilename) To UBound(aFilename) 
      iCount = iCount + 1 
      sFilename = aFilename(iFile) 
      'see if the file has already been renamed
      iPos = InStr(sFilename,sSeparator) 
      If iPos > 0 Then 
         'strip previous extra information
         sAdjustedName = Mid(sFilename,iPos + Len(sSeparator)) 
      Else 
         sAdjustedName = sFilename 
      End If 
      
      sPathFile = psPath & sFilename 
      If psFormatCode <>  "" Then 
         sExtraInfo = psPrefix _ 
         & Format(FileDateTime(sPathFile),psFormatCode) _ 
         & sSeparator 
      Else 
         sExtraInfo =  ""
      End If 
      
      sNewFilename = sExtraInfo & sAdjustedName 
      sNewPathFile = psPath & sNewFilename 
      
      sMsg = Format(iFile, "000") &  ". Rename " _ 
         & sFilename &  " to " & sNewFilename &  "?"
         
      Debug.Print 
      Debug.Print sMsg; 
      
      If pBooSkipPromptEachFile = True Then 
         booDo = True 
      Else 
         iAnswer = MsgBox(sMsg,vbYesNoCancel, "Rename this file?") 
         If iAnswer = vbYes Then 
            booDo = True 
         ElseIf iAnswer = vbNo Then 
            Debug.Print  " -- SKIP"; 
            booDo = False 
         ElseIf iAnswer = vbCancel Then 
            GoTo proc_Exit 
         End If 
      End If 
      
      If booDo Then 
         If sPathFile <> sNewPathFile Then 
            Name sPathFile As sNewPathFile 
            Debug.Print  " --> Done"; 
            iCountDone = iCountDone + 1 
         Else 
            Debug.Print  " -- NO CHANGE"; 
         End If 
      End If 

      
   Next iFile  'filename
   Debug.Print 
   
   
proc_Exit: 
   On Error Resume Next 
   psRETURNMsg =  "Done. Looped through " _ 
            & Format(iCount, "#,##0") _ 
            &  " File" & IIf(iCount <> 1, "s", "") _ 
         & vbCrLf &  "Renamed " _ 
            & Format(iCountDone, "#,##0") _ 
            &  " File" & IIf(iCountDone <> 1, "s", "") _ 
         & vbCrLf &  "in path:" _ 
         & vbCrLf & Space(3) & psPath 
   
   LoopFolder_RenameFiles = iCountDone 
   Exit Function 
  
proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   LoopFolder_RenameFiles"

   Resume proc_Exit 
   Resume 
End Function 

'--------------------------------------------------------------------------------
'                              GetArrayFilenames
'--------------------------------------------------------------------------------
Function GetArrayFilenames( _ 
   ByVal psPath As String _ 
   ,Optional psMask As String =  "*.*" _ 
   ,Optional pbRETURNpathGood As Boolean _ 
   ) As Variant 
's4p 181208, 190717, 220102
'read filenames from a folder

   'PARAMETERS
   '  psPath is path to look in
   '  psMask is what to look for (ie: *.* or specific like *.jpg)
   '  pbRETURNpathGood. Return path test
   '     True = Path Good
   '     False = Bad Path
   'RETURN
   '  filename OR unallocated array
   '
   'CALLS
   '  GetCountFiles
   '
   'USES
   '  Scripting.FileSystemObject

   '
   On Error GoTo proc_Err 

   Dim sPathFile As String _ 
     ,sFilename As String _ 
     ,nCount As Long _ 
     ,nFiles As Long 
   
   Dim aFilename() As String 
   
   'initialize return value to be unallocated array
   'LBound = 0, UBound = -1
   GetArrayFilenames = Split(vbNullString) 
      
   psPath = Trim(psPath) 
   If Right(psPath,1) <>  "\" Then 
      psPath = psPath &  "\"
   End If 
   
   nFiles = GetCountFiles(psPath)  '-1=Bad Path
   
   If nFiles < 0 Then 
      pbRETURNpathGood = False 
   Else 
      pbRETURNpathGood = True 
   End If 
   
   'no files
   If Not nFiles > 0 Then 
      Exit Function 
   End If 
   
   'avoid ReDim in the loop for better performance
   'even though mask may knock some of them out
   ReDim aFilename(1 To nFiles) 
   
   nCount = 0 
   
'   ' ---------------------------- Dir()
'   'get first file matching mask
'   sFilename = Dir(psPath & psMask)
'
'   'add to a array of filenames
'   Do While sFilename <> ""
'      If psMask = "*.*" Or sFilename Like psMask Then
'         sPathFile = psPath & sFilename
'         'this has problem with unicode characters in name
'         If (GetAttr(sPathFile) And vbDirectory) <> vbDirectory Then
'            nCount = nCount + 1
'            aFilename(nCount) = sFilename
'         End If
'      End If
'
'       'get next filename
'      sFilename = Dir()
'   Loop

   ' ---------------------------- Scripting.FileSystemObject
   'better at getting long complicated names than Dir
   For Each moFile_fso In CreateObject( "Scripting.FileSystemObject").GetFolder(psPath).Files 
      sFilename = moFile_fso.Name 
      If psMask =  "*.*" Or sFilename Like psMask Then 
         nCount = nCount + 1 
         aFilename(nCount) = sFilename 
      End If 
   Next moFile_fso 

   'see if array elements are less due to mask
   If nCount <> 0 Then 
      'path was valid but no files
      If nCount <> nFiles Then 
         'number found less than in folder
         ReDim Preserve aFilename(1 To nCount) 
      End If 
      'return filename array
      GetArrayFilenames = aFilename 
   End If 

proc_Exit: 
   On Error Resume Next 
   Exit Function 
  
proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   GetArrayFilenames"

   Resume proc_Exit 
   Resume 
End Function 
'--------------------------------------------------------------------------------
'                              alternate run_Time_LoopFolder_RenameFiles
'--------------------------------------------------------------------------------
'  Timer Function
'  https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/timer-function
'  seconds elapsed since midnight
Sub run_Time_LoopFolder_RenameFiles() 
's4p 220101
   'CALLS
   '  LoopFolder_RenameFiles

   Dim sgTimer As Single 
   sgTimer = Timer 
 
   Dim sPath As String _ 
      ,sPrefix As String _ 
      ,sgDiff As Single 
      
   sPrefix =  "catSleep_"      '----------- change me!
   sPath =  "E:\p\pic_catsSleep"    '----------- change me!
   
   Call LoopFolder_RenameFiles(sPath,True,,,sPrefix) 
   If Timer() < sgTimer Then 
      'assume total time is less than one day
      sgDiff = 60 * 60 * 24 - sgTimer + Timer 
   Else 
      sgDiff = Timer - sgTimer 
   End If 
   Debug.Print  "> " & Format(sgDiff, "#,##0.####") _ 
      &  " seconds to execute"
   
End Sub 

'--------------------------------------------------------------------------------
'                              GetCountFiles
'  duplicated here as a Private function
'--------------------------------------------------------------------------------
' http://msaccessgurus.com/VBA/Code/File_CountFiles.htm
Private Function GetCountFiles(psPath As String) As Long 
'strive4peace
'uses Late Binding. Reference for Early Binding:
'  Microsoft Scripting Runtime
   'PARAMETER
   '  psPath is folder to get the number of files for
   '     for example, c:\myPath
   ' Return: Long
   ' -1 = path not valid
   ' 0 = no files found, but path is valid
   ' 99 = number of files where 99 is some number
   
   'inialize return value
   GetCountFiles = -1 
   'skip errors
   On Error Resume Next 
   'count files in folder of FileSystemObject for path
   With CreateObject( "Scripting.FileSystemObject") 
      GetCountFiles = .GetFolder(psPath).Files.Count 
   End With 
End Function 


' LICENSE
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'   ~ crystal (strive4peace)  www.MsAccessGurus.com
'*************** Code End *******************************************************