VBA code assistance: Cannot move a compressed (Zipped) folder into itself

Home Forums VBA Forum (Visual Basic for Applications Community Support) VBA code assistance: Cannot move a compressed (Zipped) folder into itself

Viewing 1 post (of 1 total)
  • Author
  • #8048
    Lloyd BangeraLloyd Bangera

    I have the below code which was written by someone else. However there are still few issues with the code. Can you please help me.

    Major Issue with the code.

    I did try the code and the files do get zipped ( Correctly ) but the moment I uncomment the line ‘Kill vntFilePath ‘ it goes ahead and deletes the original file but also deletes the file in the zipped shell. This should not happen. Only the unzipped file should get deleted and not the file within the zipped file.

    Other issues.

    1. I get 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. In place of last accessed date, 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.

    3. 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). Can the code refer to the path if it is mentioned on the spreadsheet instead of inputting it in the code itself. This was the code doesn’t have to be static.

    Below is the code.

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

    Public Sub ZipOldFiles()


    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”
    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
    MsgBox “No files over ” & vntAgeInMonths _
    & ” month(s) old were found.”, vbInformation
    End If
    Exit Sub

    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
    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
    GetAgeInMonths = Int(strInput)
    End If
    Exit Function

    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

    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
    Resume NextFile
    Next objFile

    If blnRecursive Then
    On Error GoTo SubfolderError
    For Each objSubfolder In objFolder.SubFolders
    Call GetOldFilePaths(objSubfolder.Path, intAgeInMonths, True)
    GoTo NextSubfolder
    Resume 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)

    On Error Resume Next
    ZipFile = Not blnError
    If blnError Then objFileSystem.DeleteFile strZipFilePath
    Set objFileSystem = Nothing
    Set objShell = Nothing
    Exit Function

    blnError = True
    Resume ExitHandler
    End Function

Viewing 1 post (of 1 total)
  • You must be logged in to reply to this topic.

Comments are closed.