vba архивация файла

vba-Архивация файла.vba

Function Zip_File(ByVal FileNameXls, ByVal FileNameZip, _
                  Optional ByVal DeleteSourceFile As Boolean = False) As Boolean
     On Error Resume Next: Err.Clear:
    If Len(Dir(FileNameZip)) > 0 Then Kill FileNameZip
    If Len(Dir(FileNameXls)) = 0 Then MsgBox "Файл """ & FileNameXls & """ не найден", _
       vbCritical, "Ошибка в функции Zip_File": Exit Function
 
    Open FileNameZip For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
    Set oApp = CreateObject("Shell.Application")
    oApp.Namespace(FileNameZip).CopyHere FileNameXls    
    Do Until oApp.Namespace(FileNameZip).Items.Count = 1    
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    If DeleteSourceFile Then Kill FileNameXls   
    Zip_File = Err = 0    
End Function