lloydbangera
New Member
Code:
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 "Macro run is complete!"
'' MsgBox Format(lngZipCount, "#,0") _
'' & " of " & Format(m_lngOldFileCount, "#,0") _
'' & " old files were zipped successfully.", vbInformation
Else
MsgBox "Macro run is complete!"
''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
Rem --------------------------------------------------------------------------------------- Condition for age
If dblInput >= 0 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
Rem ---------------------------------------------------------------------- Check for age of file Date Accessed/ Date Created
' DateLastAccessed
' DateCreated
' DateLastModified
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
Dim cnt As Variant
On Error GoTo ErrorHandler
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
strParentFolderPath = objFileSystem.GetParentFolderName(strFilePath) & "\"
strBaseFileName = objFileSystem.GetBaseName(strFilePath)
cnt = objFileSystem.GetFolder(strParentFolderPath).Files.Count
strZipFilePath = strParentFolderPath & strBaseFileName & ".zip"
Dim sFile As Variant, ExtFind As Variant
sFile = Dir(strParentFolderPath & strBaseFileName & "*")
ExtFind = Right$(sFile, Len(sFile) - InStrRev(sFile, "."))
If ExtFind = "zip" Then
blnError = False
GoTo ExitHandler
End If
Debug.Print ExtFind
objFileSystem.CreateTextFile(strZipFilePath, True).Close
Set objShell = CreateObject("Shell.Application")
objShell.Namespace(CVar(strZipFilePath)).CopyHere CVar(strFilePath)
Rem ------------------------------------------------------------------------------ Wait time
Do
Application.Wait (Now + TimeValue("00:00:05"))
Loop Until objShell.Namespace(CVar(strParentFolderPath)).Items.Count <> cnt
''Application.Wait (Now + TimeValue("00:00:20"))
ExitHandler:
On Error Resume Next
ZipFile = Not blnError
If ExtFind = "zip" Then ZipFile = False
If blnError Then objFileSystem.DeleteFile strZipFilePath
Set objFileSystem = Nothing
Set objShell = Nothing
Exit Function
ErrorHandler:
blnError = True
Resume ExitHandler
End Function
Last edited by a moderator:
