asked on

How to modify VBA code to overwrite the existing zip file when coping?

I need the code to overwrite the existing file.

ub Zip_ActiveWorkbook()
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
    Dim FileExtStr As String

    DefPath = "Q:\"    '<< Change
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Create date/time string and the temporary xl* and Zip file name
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls"
    Else
        Select Case ActiveWorkbook.FileFormat
        Case 51: FileExtStr = ".xlsx"
        Case 52: FileExtStr = ".xlsm"
        Case 56: FileExtStr = ".xls"
        Case 50: FileExtStr = ".xlsb"
        Case Else: FileExtStr = "notknown"
        End Select
        If FileExtStr = "notknown" Then
            MsgBox "Sorry unknown file format"
            Exit Sub
        End If
    End If
    
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & ".zip"
    
    FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & FileExtStr

    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then

        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNameXls

        'Create empty Zip File
        NewZip (FileNameZip)

        'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls

        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).Items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
        'Delete the temporary xls file
        Kill FileNameXls

        MsgBox "The Q: drive has been updated"
    Else
        MsgBox "FileNameZip or/and FileNameXls exist"

    End If
End Sub

Open in new window

Bill Prew

This uses another procedure named NewZip, we would need to see that cope.

~bp

kbay808

ASKER

Sub NewZip(sPath)
'Create empty Zip File
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub


Function bIsBookOpen(ByRef szBookName As String) As Boolean
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function


Function Split97(sStr As Variant, sdelim As String) As Variant
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function

Open in new window

ASKER CERTIFIED SOLUTION