MS VBA | Архивировать файл

Скачать пример в zip:   ArchiveFilesExample.zip

Скачать пример в mdb: ArchiveFilesExample.mdb

'архивировать файл (.Zip, .Rar)

'процедура принимает параметры 'что запаковать' и 'куда положить'

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Const SYNCHRONIZE = &H100000

Private Const INFINITE = -1&

Public Sub CompressFiles(Archive, Files)

On Error GoTo Err

Dim cmd As String

'cmd = 'C:\Program Files\WinRAR\WinRar.exe a -afzip ''' & Archive & ''''  'команда для архива в zip

cmd = "C:\Program Files\WinRAR\WinRar.exe a """ & Archive & """" 'команда для архива в rar

Dim I As Long

For I = 0 To UBound(Files)

   cmd = cmd & " """ & Files(I) & """"

Next

  Dim processID As Long

  Dim processHandle As Long

   processID = Shell(cmd, 1)

   processHandle = OpenProcess(SYNCHRONIZE, 0, processID)

  If processHandle <> 0 Then

       WaitForSingleObject processHandle, INFINITE

       CloseHandle processHandle

  End If

Exit Sub

Err:

 Err.Raise Err.Number, "Files Archivation", Err.Description

Exit Sub

End Sub

Пример: пакуем несколько файлов с диска C: File1.xls и File2.doc в файл FilesArchive.rar:

Private Sub btnArchiveFiles_Click()

Call CompressFiles("c:\FilesArchive.rar", Array("c:\File1.xls", "c:\File2.doc"))

End Sub

См. также:

➢On Error Goto Err

➢Err.Raise