Макрос для архивации текущей (или активной) книги Excel средствами Windows(без использования сторонних программ-архиваторов) Во вложении - файл, при запуске которого автоматически срабатывает такой макрос
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
|
|||||||
Комментарии
Спасибо!
Да, возможно, если использовать программу WinRAR для создания архива.
(как создать запароленный архив средствами Windows - я не знаю)
Читаем справку программы WinRAR - и добавляем ещё один ключ в следующий код: (в строку WinRAR_Keys)
' имя создаваемого архива будет иметь вид [B]Мой архив 17-Feb-2009.exe[/B]
WinRAR_Path = """C:\Program Files\WinRAR\WinRAR.exe"""
WinRAR_Keys = " a -r -sfx -ep -agDD-MMM-YYYY "
FolderPath = "C:\Documents and Settings\Игорь\Рабочий стол\" ' папка с файлами
ArchieveFileName = Chr(34) & FolderPath & "Мой архив .exe" & Chr(34) ' имя и путь создаваемого архива
Mask = Chr(34) & FolderPath & "*.xls" & Chr(34) ' добавляем только файлы Excel
Icon = " -iicon" & Chr(34) & "C:\Program Files\Microsoft Office\OFFICE11\MSN.ICO" & Chr(34) ' иконка
CommandLine = WinRAR_Path & WinRAR_Keys & ArchieveFileName & " " & Mask & Icon
'MsgBox CommandLine
Shell CommandLine
End Sub
PS: Убрав в коде ключ -sfx, или заменив его на другой, вы получите архив RAR или ZIP
А подскажите, возможно ли в таком же плане, но чтоб архив создавался запороленным?
Посмотрел ещё раз пример из вложения к статье - ничего там не закомментировано, всё работает...
Все работает, но нужно было раскоментить вторую часть макроса, автор, зачем Вы в примере закоментили Function Zip_File ?
Добрый день.
У меня при запуске макроса ругается на вот эту строку:
ZIPresult = Zip_File(FileNameXls, FileNameZip, True)
"Sub or function not defined"
если обьявить переменную:
dim Zip_File
то в папке делается копия активной книги, но архив не создается :(
что нужно сделать, чтобы он начал работать?
Прикрепил файл с примером - то, что вы просили
(автозапуск создания резервной копии книги Excel при открытии файла)
a mojno utochnit v kakuiu stroku vstavit, potomu chto prosto v modul vstavil a ona ne deistvuet
???
zaranee spasibo no programma ochen xoroshaia
Очень просто - достаточно в МОДУЛЬ КНИГИ (модуль ЭтаКнига) добавить такой макрос:
CreateBackup ' архивация книги
End Sub
а как сделать что бы макрос запускался сам без спроса пользователя при открытии файла ?
Странно - у меня всё работает нормально.
Как обойти проблему с кодировками, не знаю, но, может, просто перестать использовать русские символы в имени файлы Excel?
Ведь архив получает корректное имя, а как называется сам файл Excel внутри этого архива, - по сути, не так уж и важно...
Я бы решил проблему так:
FileNameXls = BackupsPath & "Workbook_" & Format(Now, "DD-MM-YYYY__HH-NN-SS") & "." & ext$
Замечательная функция!
До сих пор делал подобное с помощью вызова архиваторов - очень неудобно.
Но только одно здесь у меня не получилось - русские имена файлов при упаковке превращаются в абракадабру.
т.е. сам архив имеет имя
МирУюта_СкладГП_05.03.11_09.09.zip
а внутри архива вот такое
ЊЁа“ов _‘Є« ¤ѓЏ_05.03.11_09.09.xls
Можно это как-то исправить?
Отправить комментарий