MyTetra Share
Делитесь знаниями!
Макрос создания копии файла Excel в виде архива ZIP
30.01.2018
09:09
Текстовые метки: k_zip,VBA, ZIP
Раздел: VBA

Макрос создания копии файла Excel в виде архива ZIP

Макрос для архивации текущей (или активной) книги Excel средствами Windows

(без использования сторонних программ-архиваторов)

Во вложении - файл, при запуске которого автоматически срабатывает такой макрос
При открытии этого файла, если включены макросы, в папке My Program Backups будет сохранена копия книги в формате ZIP (архив)
Папка, если таковая не существует, будет автоматически создана макросом.

 

Sub CreateBackup()
    ' Макрос создания резервной копии текущего файла
    ' Чтобы макрос обрабатывал активную книгу - замените в коде
    ' все ThisWorkbook на ActiveWorkbook
    ' Архивация файла осуществляется средствами Windows
    
    Const PROJECT_NAME = "My Program" ' название вашей программы (любой текст)
    On Error Resume Next: ThisWorkbook.Save ' сохраняем книгу Excel
    
    ' формируем путь к папке, куда будет помощена копия файла (в виде архива)
    BackupsPath = Replace(ThisWorkbook.FullName, ThisWorkbook.Name, PROJECT_NAME & " Backups\")
    MkDir BackupsPath ' создаём папку, если таковой ещё нет
    
    ext$ = Split(ThisWorkbook.Name, ".")(UBound(Split(ThisWorkbook.Name, "."))) ' расширение файла
    ' формируем путь для копии файла Excel
    FileNameXls = BackupsPath & PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & "." & ext$
    ' формируем путь для создаваемого архива ZIP
    FileNameZip = BackupsPath & PROJECT_NAME & "_BACKUP_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & ".zip"
 
    ThisWorkbook.SaveCopyAs FileNameXls ' создаём копию книги
    ZIPresult = Zip_File(FileNameXls, FileNameZip, True) ' упаковываем копию книги в архив ZIP
    
    Debug.Print "Результат архивации: " & IIf(ZIPresult, "выполнена успешно", "ошибка")
    Debug.Print "Создан архив: " & Dir(FileNameZip)
End Sub
Function Zip_File(ByVal FileNameXls, ByVal FileNameZip, _
                  Optional ByVal DeleteSourceFile As Boolean = False) As Boolean
    ' Функция осуществляет упаковку файла FileNameXls в архив с именем FileNameZip
    ' если DeleteSourceFile = TRUE, исходный файл FileNameXls удаляется по окончании архивации
    ' Возвращает TRUE, если архивация завершилось удачно, и FALSE в противном случае
    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    ' возвращаем результат упаковки (TRUE, если всё завершилось удачно)
End Function

Функция для разархивирования (извлечения файлов из архива ZIP)

Function UnZip_File(ByVal FileNameZip, ByVal DestinationFolder, _
                    Optional ByVal DeleteSourceFile As Boolean = False) As Boolean
    ' Функция осуществляет распаковку архива с именем FileNameZip в папку DestinationFolder
    ' если DeleteSourceFile = TRUE, исходный файл FileNameZip удаляется по окончании архивации
    ' Возвращает TRUE, если файлы извлечены удачно, и FALSE в противном случае
    On Error Resume Next: Err.Clear
 
    If Right(DestinationFolder, 1) <> "\" Then DestinationFolder = DestinationFolder & "\"
    MkDir DestinationFolder    ' создаём папку, если таковой ещё нет

    If Len(Dir(DestinationFolder, vbDirectory)) = 0 Then Exit Function    ' не удалось создать папку

    If Len(Dir(FileNameZip)) = 0 Then MsgBox "Файл """ & FileNameZip & """ не найден!", _
       vbCritical, "Ошибка в функции UnZip_File": Exit Function
 
    Set oApp = CreateObject("Shell.Application")
    For Each it In oApp.Namespace(FileNameZip).Items: Debug.Print it: Next
 
    oApp.Namespace(DestinationFolder).CopyHere oApp.Namespace(FileNameZip).Items    'распаковываем файлы

    If DeleteSourceFile Then Kill FileNameZip    ' удаляем исходный архив
    UnZip_File = Err = 0    ' возвращаем результат распаковки (TRUE, если всё завершилось удачно)
End Function


Вложение

Размер

Загрузки

Последняя загрузка

AutoBackupWhenOpen.xls

39 КБ

101

3 недели 1 день назад

Прикрепленные файлы:
Так же в этом разделе:
 
MyTetra Share v.0.52
Яндекс индекс цитирования