VBA_Save Compressed "windows" zip

'From Ron de Bruin: http://www.rondebruin.nl/windowsxpzip.htm
'This sub will make a copy of the Activeworkbook and zip it
'in "C:\Backup" with a date-time stamp.
'Change this folder or use your default path Application.DefaultFilePath
 
Sub Zip_ActiveWorkbook()
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
'##########CHANGE THIS TO ACTIVEWORKBOOK DIRECTORY
    DefPath = "C:\Backup" '<< Change
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
'##########REMOVE THIS, WANT THE FILE TO HAVE A DATESTAMP,
'##########NOT THE ZIP FOLDER
    'Create date/time string and the temporary xls and zip file name
    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
 Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
    FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
 Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"
 
    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'##########ADD A DATESTAMP HERE
        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNameXls
'##########ONLY CREATE A ZIP FILE IF ONE NAMED _BACKUP.zip
'##########DOESN'T ALREADY EXIST
        'Create empty Zip File
        NewZip (FileNameZip)
'##########ADD FILE TO EXISTING _BACKUP.zip folder
        '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 "Your Backup is saved here: " & FileNameZip
 
    Else
        MsgBox "FileNameZip or/and FileNameXls exist"
    End If
End Sub
Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    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
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
 
Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function

Public Function Unzip(DefPath, Fname)
'Unzips A File
'Fname must be FULL Path\Filename.zip
'DefPath must be valid Path\ you want to Unzip file TO
Dim fso As Object
Dim oApp As Object
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(DefPath).CopyHere oApp.Namespace(Fname).items
On Error Resume Next
Set fso = CreateObject("scripting.filesystemobject")
fso.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set fso = Nothing
End Function

Public Function Zipper(ZipName, FileToZip)
'Zips A File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create OR ADD To
'FileToZip must be Full Path\Filename.xls  -  Name of file you want to zip
Dim fso As Object
Dim oApp As Object
If Dir(ZipName) = "" Then
    Open ZipName For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
On Error Resume Next
Set fso = CreateObject("scripting.filesystemobject")
fso.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set fso = Nothing
End Function

'Help from:
'Ron de Bruin: http://www.rondebruin.nl/windowsxpzip.htm
'NdNoviceHlp @ mr.excel.com
'jonmo1 @ mr.excel.com
'This sub will make a copy of the Activeworkbook and zip it
'in "C:\Backup" with a date-time stamp.
'Change this folder or use your default path Application.DefaultFilePath
'Option Explicit
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim FullPathFilename As String
    Dim oApp As Object
    Dim fso As Object
Sub Zip_ActiveWorkbook()
    DefPath = ActiveWorkbook.Path '<< Change
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
 
'Create date/time string and the temporary xls and zip file name
    strDate = Format(Now, " yy-mmm-dd h-mm-ss")
 
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - 4) & "_bkp" & ".zip"
 
    FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - 4) & "_" & strDate & ".xls"
 
'Make copy of the activeworkbook
    ActiveWorkbook.SaveCopyAs FileNameXls
    If Dir(FileNameZip) = "" Then
        Open FileNameZip For Output As #1
        Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
        Close #1
    End If
 
    Set oApp = CreateObject("Shell.Application")
    oApp.Namespace(FileNameZip).CopyHere (FileNameXls)
 
'Keep script waiting until Compressing is done!!!!!!!!!Errors out here!!!!!11
    On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
    err.Clear
 
'Delete any temp files from compressing
On Error Resume Next
    Set fso = CreateObject("scripting.filesystemobject")
    fso.deletefolder Environ("Temp") & "\Temporary Directory*", True
    Set oApp = Nothing
    Set fso = Nothing
err.Clear
'Delete the temporary xls file
    Kill FileNameXls
 
    MsgBox "Your Backup is saved here: " & FileNameZip
 
FileNameZip = ""
FileNameXls = ""
 
End Sub