e xcelvba.ru

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

4-6 минут

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

Во вложении - файл, при запуске которого автоматически срабатывает такой макрос
При открытии этого файла, если включены макросы, в папке 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