Страницы: 1
RSS
Зиповать папку (.zip). VBA
 
Добрый день!  
Не подскажете код, с помощью VBA(Excel) автоматически зиповать (.zip) определенную папку?    
Заранее благодарен!
With my best regards,      Inter_E
 
{quote}{login=Inter_E}{date=20.08.2009 09:55}{thema=Зиповать папку (.zip). VBA}{post}Добрый день!  
Не подскажете код, с помощью VBA(Excel) автоматически зиповать (.zip) определенную папку?    
Заранее благодарен!{/post}{/quote}  
Переписать алгритм архивации ZIP на VBA, насколько я помню архив типа zip является стандартизованным и открытым.Его описание можно поискать в сети.  
 
PS Шутко. Но в в каждой шутке есть доля правды :)
 
{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". И вот таким образом рядом с файлом появляется его клон-зип.    
Дополнительно прикрепляю рисунок!!
With my best regards,      Inter_E
 
http://www.rondebruin.nl/windowsxpzip.htm  
http://www.rondebruin.nl/windowsxpunzip.htm  
http://www.rondebruin.nl/zip.htm  
http://www.rondebruin.nl/unzip.htm  
http://www.rondebruin.nl/7zipwithexcel.htm  
http://www.rondebruin.nl/7zipwithexcelunzip.htm
KL
 
Делал тут как-то надстройку для архивации файлов:  
 
http://i048.radikal.ru/0908/56/3871d2b19c4a.jpg  
 
Но не проверял её на папках (впрочем, достаточно в коде изменить пару строк, чтобы обрабатывались папки целиком.  
 
Если такое подойдёт - могу выложить код.  
 
Код выглядит примерно так:  
 
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  
 
   ArchievePassword = Settings.[b14]
   WinRAR_Path = "" & WinRAR_Exe_FullPath & ""  
   WinRAR_Keys = " a -r -sfx -k -ep1 -rr5p -av -ibck -m5 -s "    ' дата: -agDD-MMM-YYYY  
   If WBType <> EXE Then WinRAR_Keys = Replace(WinRAR_Keys, "-sfx ", "")  
   WinRAR_Keys = WinRAR_Keys & "-z" & Chr(34) & CreateCommentForFolderArchieve(FolderPath) & Chr(34) & " "  
   WinRAR_Keys = WinRAR_Keys & "-hp" & Chr(34) & ArchievePassword & Chr(34) & " "  
   Debug.Print ArchievePassword  
 
   Create_Folder_Archieve = GetNewFileName_forArchieve(WBType, True)  
   ArchieveFileName = Chr(34) & Create_Folder_Archieve & Chr(34)   ' имя и путь создаваемого архива  
   'Mask = Chr(34) & FolderPath & "*.xls" & Chr(34)    ' добавляем только файлы Excel  
   Mask = Chr(34) & FolderPath & Chr(34)    ' добавляем только один файл  
   Icon = " -iicon" & Chr(34) & SFX_Icon_FullPath & Chr(34)    ' иконка  
   If Dir(SFX_Logo_FullPath, vbNormal) <> "" Then Icon = Icon & " -iimg" & Chr(34) & SFX_Logo_FullPath & Chr(34)    ' добавляем логотип  
 
   CommandLine = WinRAR_Path & WinRAR_Keys & ArchieveFileName & " " & Mask & Icon  
   Shell (CommandLine)  
   If Dir(Create_Folder_Archieve) = "" Then Create_Folder_Archieve = ""  
   'MsgBox ShellExecute(0&, vbNullString, WinRAR_Path, WinRAR_Keys & ArchieveFileName & " " & Mask & Icon, vbNullString, vbNormalFocus)  
End 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)
Страницы: 1
Читают тему
Наверх