{quote}{login=Inter_E}{date=20.08.2009 09:55}{thema=Зиповать папку (.zip). VBA}{post}Добрый день! Не подскажете код, с помощью VBA(Excel) автоматически зиповать (.zip) определенную папку? Заранее благодарен!{/post}{/quote} Переписать алгритм архивации ZIP на VBA, насколько я помню архив типа zip является стандартизованным и открытым.Его описание можно поискать в сети.
{quote}{login=The_Prist}{date=20.08.2009 12:04}{thema=}{post}Как .zip-ом не знаю(негде сейчас опробовать - на работе RAR). Может получится просто заменить имя архиватора {/post}{/quote}
Спасибо The_Prist, я проверил хорошо работает Rar. A чтоб c zip-ом, ну допустим хотел поменять код ваш, но там в С\program files как будет программа архиваций zip-a (или где он, программа zipa)
2) а что касается ответа JOM, а где это можно в сети взять алгоритм Зипа?
Обычно на работе я зипую следующим способом: так как у нас Виндоуз на английском, я нажимаю на Экселевском файле правую кнопку и в меню выбираю (6-ой снизу) команду "Send To" дальше в правом появившем меню вибираю значок зипа, рядом написано "Compressed(zipped)Folder". И вот таким образом рядом с файлом появляется его клон-зип. Дополнительно прикрепляю рисунок!!
Но не проверял её на папках (впрочем, достаточно в коде изменить пару строк, чтобы обрабатывались папки целиком.
Если такое подойдёт - могу выложить код.
Код выглядит примерно так:
Private Sub testWinRAR() Create_Archieve "C:\WINDOWS\Temp\Excel\Workbooks\Sample.xls", RAR Create_Archieve "C:\WINDOWS\Temp\Excel\Workbooks\Sample.xls", ZIP Create_Archieve "C:\WINDOWS\Temp\Excel\Workbooks\Sample.xls", EXE End Sub
Private Sub testWinRAR_2() Debug.Print Create_Folder_Archieve("C:\Documents and Settings\Игорь\Рабочий стол\Новая папка\*.*", EXE) End Sub
Вот одна из используемых процедур:
Function Create_Folder_Archieve(ByVal FolderPath As String, ByVal WBType As File_Type) As String If WBType = XLS Or WBType = ZIP_Windows Then Exit Function
WinRAR_Exe_FullPath = Settings.[b10]: SFX_Icon_FullPath = Settings.[b11]: SFX_Logo_FullPath = Settings.[b12] If Dir(SFX_Icon_FullPath, vbNormal) = "" Then SFX_Icon_FullPath = Application.Path & "\MSN.ICO" msg = "Файл WinRAR.exe не найден" & vbNewLine & vbNewLine & "Проверьте правильность указания пути к файлу: " & WinRAR_Exe_FullPath If Dir(WinRAR_Exe_FullPath, vbNormal) = "" Then MsgBox msg, vbCritical, "Не удалось создать архив": Exit Function
Для создания ZIP-архива средствами Windows я использую такой код:
Function Zip_File(ByVal filename As String, Optional ByVal DeleteSourceFile As Boolean = False) As String FileNameZip = GetNewFileName_forArchieve(ZIP, CHB_UseDefaultFileNames): If FileNameZip = "" Then Exit Function FileNameXls = GetNewFileName_forXLS(True) FileCopy filename, FileNameXls If Dir(FileNameZip) = "" And Dir(FileNameXls) <> "" Then NewZip (FileNameZip) 'Create empty Zip File
Set oApp = CreateObject("Shell.Application") oApp.Namespace(FileNameZip).CopyHere FileNameXls 'Copy the file in the compressed folder On Error Resume Next Do Until oApp.Namespace(FileNameZip).Items.Count = 1 'Keep script waiting until Compressing is done Application.Wait (Now + TimeValue("0:00:01")) Loop On Error GoTo 0 Else MsgBox "Dir(FileNameZip) <> "" or Dir(FileNameXls) = """, vbCritical, "Function Zip_Workbook": Exit Function End If If DeleteSourceFile Then Kill FileNameXls ' удаляем временно созданный файл Zip_File = FileNameZip End Function
Sub NewZip(sPath) 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
Пример использования:
filename="C:\Documents and Settings\Рабочий стол\speedcam" ПутьКСозданномуАрхиву = Zip_File(filename)