VBA code required to zip files on folders / Sub folders

[lloydbangera]

Hello All,

I hope all of you are doing well. Can you kindly assist me on the below. I am struggling for months to get this code. I am not an expert at coding hence requesting you all to help me out.

Below are the requirements the code.

1. The VBA should go through all the folder and sub-folders and check each and every type of file. The user should only give the path of the top folder. The code should detect all the folders and sub-folders
2. After checking the files, the code should zip all files which have not been accessed for more than 3 months. The accessed period is something which the user should be able to decide. It can change from 1
month to 6 months.
3. After zipping the file, the code should delete the original file and only keep the zipped file.
4. The zipped file should be saved in the same path as the original file.

 

[ParamRay]

Here is the entire code module. I have commented out the line that deletes the original file. To be safe, only uncomment it after testing.

Option Explicit
Dim m_astrOldFilePaths() As String
Dim m_lngOldFileCount As Long

Public Sub ZipOldFiles()

  '++++++++++++++++++++++++++
  '+++ RUN THIS PROCEDURE +++
  '++++++++++++++++++++++++++
  
  Dim vntAgeInMonths
  Dim vntFolderPath
  Dim vntFilePath
  Dim lngZipCount As Long
  Dim wksResults As Worksheet
  
  On Error GoTo ErrorHandler
  Erase m_astrOldFilePaths
  m_lngOldFileCount = 0
  
  vntFolderPath = GetFolderPath()
  If IsEmpty(vntFolderPath) Then Exit Sub
  
  vntAgeInMonths = GetAgeInMonths()
  If IsEmpty(vntAgeInMonths) Then Exit Sub
  
  Call GetOldFilePaths(CStr(vntFolderPath), CInt(vntAgeInMonths), True)
  If m_lngOldFileCount > 0 Then
    On Error Resume Next
    Set wksResults = ThisWorkbook.Sheets("ZIP RESULTS")
    
    On Error GoTo ErrorHandler
    If wksResults Is Nothing Then
      Set wksResults = ThisWorkbook.Sheets.Add()
      wksResults.Name = "ZIP RESULTS"
    Else
      wksResults.Activate
      wksResults.Cells.Clear
    End If
    
    wksResults.Range("A1").Value = "The following files were zipped..."
    wksResults.Range("A1").Font.Bold = True
    
    For Each vntFilePath In m_astrOldFilePaths
      If ZipFile(CStr(vntFilePath)) Then
        lngZipCount = lngZipCount + 1
        wksResults.Range("A" & lngZipCount + 2).Value = vntFilePath
        'Kill vntFilePath ' <-- Only uncomment after testing!
      End If
    Next vntFilePath
    
    MsgBox Format(lngZipCount, "#,0") _
      & " of " & Format(m_lngOldFileCount, "#,0") _
      & " old files were zipped successfully.", vbInformation
  Else
    MsgBox "No files over " & vntAgeInMonths _
         & " month(s) old were found.", vbInformation
  End If
  Exit Sub
  
ErrorHandler:
  MsgBox Err.Description, vbExclamation
End Sub

Private Function GetAgeInMonths()
  Dim blnValid As Boolean
  Dim strInput As String
  Dim dblInput As Double
  
  On Error GoTo ErrorHandler
  Do
    strInput = InputBox("Enter age in months:", "Zip Old Files", 3)
    If strInput <> vbNullString Then
      If IsNumeric(strInput) Then
        dblInput = Val(strInput)
        If dblInput = Int(strInput) Then
          If dblInput >= 1 And dblInput <= 6 Then
            blnValid = True
          End If
        End If
      End If
      If Not blnValid Then
        MsgBox "You must enter a whole number between 1 and 6.", vbExclamation
      End If
    End If
  Loop Until (strInput = vbNullString) Or blnValid
  
  If strInput = vbNullString Then
    GetAgeInMonths = Empty
  Else
    GetAgeInMonths = Int(strInput)
  End If
  Exit Function
  
ErrorHandler:
  GetAgeInMonths = Empty
End Function

Private Function GetFolderPath()
  Const msoFileDialogFolderPicker = 4
  Dim objFolderPicker As Object
  
  On Error GoTo ErrorHandler
  Set objFolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
  objFolderPicker.Title = "Zip Old Files"
  objFolderPicker.ButtonName = "Select Folder"
  
  If objFolderPicker.Show() Then
    GetFolderPath = objFolderPicker.SelectedItems(1)
  End If
  Exit Function

ErrorHandler:
  GetFolderPath = Empty
End Function

Private Sub GetOldFilePaths(strFolderPath As String, _
    intAgeInMonths As Integer, _
    Optional blnRecursive As Boolean = False)
  
  Dim objFileSystem As Object
  Dim objSubfolder As Object
  Dim objFolder As Object
  Dim objFile As Object
  
  Set objFileSystem = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFileSystem.GetFolder(strFolderPath)
  
  On Error GoTo FileError
  For Each objFile In objFolder.Files
    If objFile.DateLastAccessed < DateAdd("m", -intAgeInMonths, Now()) Then
      m_lngOldFileCount = m_lngOldFileCount + 1
      ReDim Preserve m_astrOldFilePaths(1 To m_lngOldFileCount)
      m_astrOldFilePaths(m_lngOldFileCount) = objFile.Path
    End If
    GoTo NextFile
FileError:
    Err.Clear
    Resume NextFile
NextFile:
  Next objFile
  
  If blnRecursive Then
    On Error GoTo SubfolderError
    For Each objSubfolder In objFolder.SubFolders
      Call GetOldFilePaths(objSubfolder.Path, intAgeInMonths, True)
      GoTo NextSubfolder
SubfolderError:
      Err.Clear
      Resume NextSubfolder
NextSubfolder:
    Next objSubfolder
  End If
  
  Set objFileSystem = Nothing
  Set objSubfolder = Nothing
  Set objFolder = Nothing
  Set objFile = Nothing
End Sub

Private Function ZipFile(strFilePath As String) As Boolean
  Dim strParentFolderPath As String
  Dim strBaseFileName As String
  Dim strZipFilePath As String
  Dim objFileSystem As Object
  Dim blnError As Boolean
  Dim objShell As Object
  
  On Error GoTo ErrorHandler
  Set objFileSystem = CreateObject("Scripting.FileSystemObject")
  strParentFolderPath = objFileSystem.GetParentFolderName(strFilePath) & "\"
  strBaseFileName = objFileSystem.GetBaseName(strFilePath)
  strZipFilePath = strParentFolderPath & strBaseFileName & ".zip"
  objFileSystem.CreateTextFile(strZipFilePath, True).Close
  Set objShell = CreateObject("Shell.Application")
  objShell.Namespace(CVar(strZipFilePath)).CopyHere CVar(strFilePath)
  
ExitHandler:
  On Error Resume Next
  ZipFile = Not blnError
  If blnError Then objFileSystem.DeleteFile strZipFilePath
  Set objFileSystem = Nothing
  Set objShell = Nothing
  Exit Function
  
ErrorHandler:
  blnError = True
  Resume ExitHandler
End Function

 

[lloydbangera]

Hello,
Thank you very much for the code. I will always be in debt to you. I did check the code and I found the below issue.

1. I got an error message stating " Cannot move a compressed (Zipped) folder into itself " - I am assuming one cannot zip an already zipped file. In this case, can the code just skip that file and move forward.
2. When I tried to uncomment on the "Kill vntFilePath " code, it would delete the files but the zipped files would be blank. The zipped folder would be blank. Not sure why this would happen.
3. In place of accessed, can we modify the code to zip files not modified or date created. Some teams would want to zip and delete based on modified or create date option.
4. Would it be possible to not have any message boxes in place. My folder has close to 800,000 files and I would want the code to run non-stop in the background without a comment box opening. We simply need to put in the options at the start while running the macro ( i.e. whether user needs to zip and delete files based on accessed, modified or created and the months)

A biggest thank you in advance.