1

2

Option Explicit

Const sWinRarAppPath As String = "C:\Program Files\WinRAR\WinRAR.exe"

1

2

3

4

5

6

7

8

9

10

11

12

13

14

Sub CallRARFunction()

    'Архивируем папку "C:\Temp\Тест"

    If FolderToRAR("C:\Temp\Тест") Then

        MsgBox "Папка успешно заархивирована!", vbInformation, "www.excel-vba.ru" '

    End If

    'Архивируем файл C:\Temp\Test.xls

    If FileToRAR("C:\Temp\", "Test.xls", "Test.rar") Then

        MsgBox "Файл успешно заархивирован!", vbInformation, "www.excel-vba.ru" '

    End If

    'Извлекаем из архива "C:\Temp\Test" файлы в папку с архивом "C:\Temp\" '

    If UnRAR("C:\Temp\Test", "Test.rar") Then

        MsgBox "Файлы успешно распакованы!", vbInformation, "www.excel-vba.ru" '

    End If

End Sub

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

'---------------------------------------------------------------------------------------

' Procedure : FolderToRAR

' Author    : The_Prist(Щербаков Дмитрий)

'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

'             http://www.excel-vba.ru

' Purpose   : Функция архивирует указанную папку

'             sPath       - путь к папке для архивации

'---------------------------------------------------------------------------------------

Function FolderToRAR(sPath As String)

    Dim sArhiveName As String

    Dim sWinRarApp As String

    sWinRarApp = sWinRarAppPath & " A -ep " '

    sArhiveName = sPath & ".rar" '

    'добавляем двойные кавычки, что позволит нам работать с именем файла и путём, которые содержат пробелы.

    'без кавычек пробелы недопустимы

    FolderToRAR = Shell(sWinRarApp & " """ & sArhiveName & """ """ & sPath & """ ", vbHide)

End Function

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

'---------------------------------------------------------------------------------------

' Procedure : FileToRAR

' Author    : The_Prist(Щербаков Дмитрий)

'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

'             http://www.excel-vba.ru

' Purpose   : Функция архивирует указанный файл

'             sPath       - путь к файлу для архивации

'             sFileName   - имя файла для архивации

'             sArhiveName - имя результирующего архива

'---------------------------------------------------------------------------------------

Function FileToRAR(sPath As String, sFileName As String, ByVal sArhiveName As String)

    Dim sWinRarApp As String

    'архивируем файл с удалением самого файла после архивации(за это отвечает параметр -df )

    sWinRarApp = sWinRarAppPath & " A -ep -df "

    'добавляем двойные кавычки, что позволит нам работать с именем файла и путём, которые содержат пробелы.

    'без кавычек пробелы недопустимы

    FileToRAR = Shell(sWinRarApp & " """ & sPath & sArhiveName & """ """ & sPath & sFileName & """ ", vbHide)

End Function

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

'---------------------------------------------------------------------------------------

' Procedure : UnRAR

' Author    : The_Prist(Щербаков Дмитрий)

'             WebMoney - R298726502453; Яндекс.Деньги - 41001332272872

'             http://www.excel-vba.ru

' Purpose   : Функция извлекает данные из указанного архива в папку с файлом архива

'             sPath       - путь к архиву

'             sArhiveName - имя архива

'---------------------------------------------------------------------------------------

Function UnRAR(sPath As String, sArhivName As String)

    Dim sWinRarApp As String

    'извлекаем данные из архива в скрытом окне(vbHide)

    'с перезаписью существующих файлов (-o+)

    sWinRarApp = sWinRarAppPath & " E -o+ "

    'добавляем двойные кавычки, что позволит нам работать с именем файла и путём, которые содержат пробелы.

    'без кавычек пробелы недопустимы

    UnRAR = Shell(sWinRarApp & " """ & sPath & "\" & sArhivName & """ """ & sPath & """ ", vbHide)

End Function

команда

Комбинация символов, определяющая действие, которое будет выполнять WinRAR.

ключ

Ключи используются для определения специфических действий, степени сжатия, типа архива и пр.

архив

Имя обрабатываемого архива.

файлы

Имена обрабатываемых файлов.

файл-список

Файлы-списки - это обычные текстовые файлы, содержащие имена файлов для обработки. Каждое имя файла должно быть указано на отдельной строке и начинаться с первой позиции строки. В файл-список допускается помещать комментарии, признак начала комментария - символы //. Например, для архивирования файлов *.txt из папки c:\work\doc, файлов *.bmp из папки c:\work\image и всех файлов из папки c:\work\misc можно создать backup.lst, содержащий следующие строки:
c:\work\doc\*.txt//резервная копия текстовc:\work\image\*.bmp//резервная копия рисунковc:\work\misc

После этого для архивирования достаточно будет выполнить команду:
winrar a backup @backup.lst

В одной командной строке разрешается указывать как обычные имена или группы файлов для обработки, так и файлы-списки. Если не указаны ни файлы, ни файлы-списки, то подразумевается шаблон *.* (т.е. WinRAR обработает все файлы).

путь для извлечения

Используется только с командами e и x и указывает папку, в которую нужно извлекать файлы. Если эта папка не существует, то она будет создана.

-ac

Снять атрибут "архивный" после архивации или извлечения

-ad

Добавить к пути назначения имя архива

-af<тип>

Указать формат архива

-ag[формат]

Добавить к имени архива текущую дату и время

-ao

Добавить файлы с установленным атрибутом "архивный"

-ap<путь>

Установить путь внутри архива

-as

Синхронизировать содержимое архива

-av

Добавить электронную подпись

-av-

Запретить добавление/проверку электронной подписи

-cfg-

Игнорировать профиль по умолчанию и переменную окружения

-cl

Преобразовать имена файлов в нижний регистр

-cu

Преобразовать имена файлов в верхний регистр

-df

Удалить файлы после архивации

-dh

Открывать совместно используемые файлы

-ds

Не сортировать файлы при архивации

-ed

Не добавлять пустые папки

-en

Не добавлять блок "конец архива"

-ep

Исключить пути из имён

-ep1

Исключить из пути базовую папку

-ep2

Сохранять полные пути файлов

-ep3

Сохранять полные пути, включая букву диска

-e[+]<атр>

Задать исключение или включение файлов из/в обработку по маске атрибутов

-f

Освежить имеющиеся файлы

-hp[пароль]

Шифровать и данные, и заголовки файлов

-iadm

Запрашивать административный доступ для SFX-архива

-ibck

Запустить WinRAR как фоновый процесс в системном лотке

-ieml[.][адрес]

Отправить архив по электронной почте

-iicon<имя >

Указать значок для SFX-модуля

-iimg<имя>

Указать логотип для SFX-модуля

-ilog[имя]

Записывать протокол ошибок в файл

-inul

Не выводить сообщения об ошибках

-ioff

Выключить компьютер

-k

Заблокировать архив

-kb

Сохранять на диске файлы, извлечённые с ошибками

-m<n>

Установить метод сжатия

-mc<параметры>

Указать дополнительные параметры сжатия

-md<n>

Установить размер словаря

-ms[список]

Указать типы файлов для архивирования без сжатия

-mt<потоки>

Установить число потоков

-n<файл>

Включить в обработку только указанный файл

-n@<файл-список>

Включить в обработку только файлы, указанные в файле-списке

-oc

Установить NTFS-атрибут "сжатый"

-or

Переименовывать файлы автоматически

-os

Сохранить потоки NTFS

-ow

Обработать информацию о правах доступа к файлам

-o+

Перезаписывать существующие файлы

-o-

Не перезаписывать существующие файлы

-p[пароль]

Установить пароль

-r

Обрабатывать вложенные папки

-r0

Обрабатывать вложенные папки по шаблону

-ri

Установить приоритет и время простоя

-rr[N]

Добавить информацию для восстановления

-rv[N]

Создать тома для восстановления

-s

Создать непрерывный архив

-s<N>

Создать непрерывные группы, используя счётчик файлов

-sc<набор символов>[объекты]

Указать набор символов (и объекты)

-se

Создать непрерывные группы, используя расширения файлов

-sfx[имя]

Создать самораспаковывающийся архив

-sl<размер>

Обрабатывать файлы размером меньше указанного

-sm<размер>

Обрабатывать файлы размером больше указанного

-sv

Создать независимые непрерывные тома

-sv-

Создать зависимые непрерывные тома

-s-

Запретить создание непрерывных архивов

-t

Протестировать файлы после архивирования

-ta<дата>

Обрабатывать файлы, изменённые после указанной даты

-tb<дата>

Обрабатывать файлы, изменённые до указанной даты

-tk

Сохранять исходное время архива

-tl

Установить время архива по самому новому файлу

-tn<время>

Обрабатывать файлы не старее, чем указанный период времени

-to<время>

Обрабатывать файлы более старые, чем указанный период времени

-ts<m,c,a>

Сохранить/восстановить время файлов (модификации, создания, последнего доступа)

-u

Обновить файлы

-v<n>[k |b|f|m|M|g|G]

Создать многотомный архив

-vd

Очищать сменный диск перед архивацией на него

-ver[n]

Управление версиями файлов

-vn

Использовать старую схему именования томов

-vp

Делать паузу перед каждым томом

-x<файл >

Не обрабатывать указанный файл

-x@<файл-список >

Не обрабатывать файлы, указанные в файле-списке

-y

Подразумевать ответ "Да" на все запросы

-z<файл>

Прочитать комментарий архива из файла

--

Прервать дальнейший поиск ключей в командной строке

vbNormalFocus

Будет показан ход выполнения архивации

vbHide

Окно архиватора будет скрыто

vbMinimizedFocus

Окно архиватора будет свернуто

vbMinimizedNoFocus

Окно архиватора будет свернуто, а окно вызвавшей программы активировано

vbMaximizedFocus

Окно архиватора будет раскрыто на весь экран и активировано

1

2

3

4

5

6

7

8

9

10

11

12

13

'---------------------------------------------------------------------------------------

' Procedure : CreateNewZip

' DateTime  : 03.08.2014 21:55

' Author    : The_Prist(Щербаков Дмитрий)

'             http://www.excel-vba.ru

' Purpose   : Основная процедура создания пустого ZIP-архива

'---------------------------------------------------------------------------------------

Sub CreateNewZip(sPath As String)

    If Dir(sPath) <> "" 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

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

'---------------------------------------------------------------------------------------

' Procedure : Zip_File_Or_Files

' DateTime  : 03.08.2014 21:54

' Author    : The_Prist(Щербаков Дмитрий)

'             http://www.excel-vba.ru

' Purpose   : Архивация выбранных файлов

'---------------------------------------------------------------------------------------

Sub Zip_File_Or_Files()

    Dim sDate As String, sZIPPath As String, sZIPFileName As String, sWBName As String

    Dim objShell As Object, lf As Long, lZIPCnt As Long

    Dim avFiles

    'Выбираем файл/файлы, которые необходимо поместить в архив

    'чтобы выбирать не только файлы Excel:"All Files (*.*), *.*"

    avFiles = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", , "Выбрать файлы для архивации", , True)

    If VarType(avFiles) = vbBoolean Then Exit Sub

    'создаем путь для создания архива(папка с выбранными файлами)

    sZIPPath = Replace(avFiles(1), Dir(avFiles(1), 16), "")

    If Right(sZIPPath, 1) <> "\" Then

        sZIPPath = sZIPPath & "\"

    End If

    sDate = Format(Now, " dd-mm-yy h-mm-ss")

    sZIPFileName = sZIPPath & "VBAZip " & sDate & ".zip"

    'создаем пустой ZIP-архив

    CreateNewZip (sZIPFileName)

    Set objShell = CreateObject("Shell.Application")

    lZIPCnt = 0

    For lf = LBound(avFiles) To UBound(avFiles)

        sWBName = Dir(avFiles(lf), 16)

        If IsBookOpen(sWBName) Then

            MsgBox "Невозможно поместить книгу '" & avFiles(lf) & "' в архив!" & vbNewLine & _

                   "Закройте книгу и повторите попытку."

        Else

            'помещаем файл в архив

            lZIPCnt = lZIPCnt + 1

            objShell.Namespace((sZIPFileName)).CopyHere CStr(avFiles(lf))

            'дожидаемся окончания архивации(особенно актуально для больших файлов)

            Do Until objShell.Namespace((sZIPFileName)).Items.Count = lZIPCnt

                DoEvents

            Loop

        End If

    Next lf

    If lZIPCnt Then

        MsgBox "Архив создан по пути: " & sZIPFileName, vbInformation, "www.excel-vba.ru"

    End If

End Sub

'---------------------------------------------------------------------------------------

' Procedure : IsBookOpen

' Purpose   : функция проверяет, отрыта ли книга в данный момент.

'             Если открыта - её невозможно поместить в архив

'             http://www.excel-vba.ru/chto-umeet-excel/kak-proverit-otkryta-li-kniga/

'---------------------------------------------------------------------------------------

Function IsBookOpen(wbName As String) As Boolean

    Dim wbBook As Workbook: On Error Resume Next

    Set wbBook = Workbooks(wbName)

    IsBookOpen = Not wbBook Is Nothing

End Function

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

'---------------------------------------------------------------------------------------

' Procedure : Zip_All_Files_in_Folder

' DateTime  : 03.08.2014 21:53

' Author    : The_Prist(Щербаков Дмитрий)

'             http://www.excel-vba.ru

' Purpose   : Создание архива из всех файлов в указанной папке

'---------------------------------------------------------------------------------------

Sub Zip_All_Files_in_Folder()

    Dim sFolderName As String, oFolder As Object

    Dim sDate As String, sZIPPath As String, sZIPFileName As String

    Dim objShell As Object

    sZIPPath = Application.DefaultFilePath

    If Right(sZIPPath, 1) <> "\" Then

        sZIPPath = sZIPPath & "\"

    End If

    sDate = Format(Now, " dd-mm-yy h-mm-ss")

    sZIPFileName = sZIPPath & "VBAZip " & sDate & ".zip"

    Set objShell = CreateObject("Shell.Application")

    'Выбираем папку

    With Application.FileDialog(msoFileDialogFolderPicker)

        If .Show = False Then Exit Sub

        sFolderName = .SelectedItems(1)

    End With

    'создаем пустой ZIP-архив

    CreateNewZip (sZIPFileName)

    If Right(sFolderName, 1) <> "\" Then

        sFolderName = sFolderName & "\"

    End If

    'помещаем файлы из папки в архив

    objShell.Namespace((sZIPFileName)).CopyHere objShell.Namespace((sFolderName)).Items

    'дожидаемся окончания архивации

    Do Until objShell.Namespace((sZIPFileName)).Items.Count = objShell.Namespace((sFolderName)).Items.Count

        DoEvents

    Loop

    MsgBox "Архив создан по пути: " & sZIPFileName, vbInformation, "www.excel-vba.ru"

End Sub

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

'---------------------------------------------------------------------------------------

' Procedure : Zip_ActiveWorkbook

' DateTime  : 03.08.2014 21:54

' Author    : The_Prist(Щербаков Дмитрий)

'             http://www.excel-vba.ru

' Purpose   : Создание архива с резервной копией активной книги

'---------------------------------------------------------------------------------------

Sub Zip_ActiveWorkbook()

    Dim sDate As String, sZIPPath As String

    Dim sZIPFileName, sBackupFileName

    Dim objShell As Object

    Dim sEx As String, lp As Long

    sZIPPath = Environ("TEMP")    'путь по умолчанию к папке временных файлов

    'можно указать любой, например

    'sZIPPath = "C:\temp" 'путь должен существовать

    If Right(sZIPPath, 1) <> "\" Then

        sZIPPath = sZIPPath & "\"

    End If

    'получаем расширение активной книги

    lp = InStrRev(ActiveWorkbook.Name, ".")

    If lp > 0 Then

        sEx = Mid(ActiveWorkbook.Name, lp)

    End If

    If Not sEx Like ".xl*" Then

        MsgBox "Неизвестный формат активной книги", vbInformation, "www.excel-vba.ru"

        Exit Sub

    End If

    sDate = Format(Now, " yyyy-mm-dd h-mm-ss")

    'имя архива

    sZIPFileName = sZIPPath & Left(ActiveWorkbook.Name, _

                                   Len(ActiveWorkbook.Name) - Len(sEx)) & sDate & ".zip"

    'имя временного файла

    sBackupFileName = sZIPPath & Left(ActiveWorkbook.Name, _

                                      Len(ActiveWorkbook.Name) - Len(sEx)) & sDate & sEx

    'если файла архива и такой же книги еще нет в папке

    If Dir(sZIPFileName) = "" And Dir(sBackupFileName) = "" Then

        'создаем копию активной книги

        'т.к. открытую книгу нельзя поместить в архив

        ActiveWorkbook.SaveCopyAs sBackupFileName

        'создаем пустой ZIP-архив

        CreateNewZip (sZIPFileName)

        'помещаем файл в архив

        Set objShell = CreateObject("Shell.Application")

        objShell.Namespace((sZIPFileName)).CopyHere sBackupFileName

        'дожидаемся окончания архивации

        Do Until objShell.Namespace((sZIPFileName)).Items.Count = 1

            DoEvents

        Loop

        'удаляем временный файл

        Kill sBackupFileName

        MsgBox "Резервная копия книги создана по пути: " & sZIPFileName, vbInformation, "www.excel-vba.ru"

    Else

        MsgBox "Невозможно создать архив, т.к. такая книга или архив уже присутствуют в папке", vbInformation, "www.excel-vba.ru"

    End If

End Sub

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

'---------------------------------------------------------------------------------------

' Procedure : ExtractFileFromZip

' DateTime  : 03.08.2014 22:02

' Author    : The_Prist(Щербаков Дмитрий)

'             http://www.excel-vba.ru

' Purpose   : Извлечение из архива конкретного файла

'---------------------------------------------------------------------------------------

Sub ExtractFileFromZip()

'C:\Documents            - папка для извлечения файла из архива

'C:\Documents\VBAZip.zip - имя ZIP-архива, из которого необходимо извлечь файл

'Книга1.xls              - имя файла в ZIP-архиве, который необходимо извлечь

    With CreateObject("Shell.Application").Namespace(("C:\Documents"))

        .CopyHere "C:\Documents\VBAZip.zip" & "\" & "Книга1.xls"

    End With

End Sub

1

2

3

4

5

6

7

8

9

10

11

12

13

14

'---------------------------------------------------------------------------------------

' Procedure : ExtractFromZipToFolder

' DateTime  : 03.08.2014 21:55

' Author    : The_Prist(Щербаков Дмитрий)

'             http://www.excel-vba.ru

' Purpose   : Извлечение всех файлов из архива

'---------------------------------------------------------------------------------------

Sub ExtractAllFilesFromZip()

'"C:\Documents"            - папка для извлечения файлов из архива

'"C:\Documents\VBAZip.zip" - имя ZIP-архива, из которого необходимо извлечь файлы

    With CreateObject("Shell.Application")

        .Namespace(("C:\Documents")).CopyHere .Namespace(("C:\Documents\VBAZip.zip")).Items

    End With

End Sub