1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

'***************************************************************

Function CreateArchive(ZipArchivePath) As Boolean

Dim Shell As Object

Dim FileSystemObject As Object

Dim ArchiveFolder As Object

      Set Shell = CreateObject("Shell.Application")

      Set FileSystemObject = CreateObject("Scripting.FileSystemObject")

      ' Проверка наличия расширения zip в полном пути-имени файла

     If UCase(FileSystemObject.GetExtensionName(ZipArchivePath)) <> "ZIP" Then

           Exit Function

      End If

      ' Создание пустого zip архива

Dim ZipFileHeader As String

      ZipFileHeader = "PK" & Chr(5) & Chr(6) & String(18, 0)

      FileSystemObject.OpenTextFile(ZipArchivePath, 2, True).Write ZipFileHeader

      Set ArchiveFolder = Shell.NameSpace((ZipArchivePath))

      ' проверка создания архива

     If Not (ArchiveFolder Is Nothing) Then CreateArchive = True

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

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

59

60

61

62

63

64

65

66

67

68

69

70

71

72

73

74

75

76

77

78

Function ZipCont(ArcName As String) As String()

Dim Fnames() As String

   ReDim Fnames(1 To 300) As String

   ZIP% = FreeFile

   Open ArcName For Binary Access Read As #ZIP%

   PZip& = 0

   ptrF% = 0

   sz% = 300

   Do

      C30$ = Space$(30)

      Get ZIP%, , C30$

      PZip& = PZip& + 30

      If Mid$(C30$, 3, 2) <> Chr$(3) + Chr$(4) Then Exit Do

      Ln% = CVI(Mid$(C30$, 27, 2))

      NameFile$ = Space$(Ln%)

      Get ZIP%, , NameFile$

      PZip& = PZip& + Ln%

      C4$ = Mid$(C30$, 19, 4)

      LL& = CVL(C4$)

      L% = Len(NameFile$)

      For ia% = L% To 1 Step -1

          If Mid$(NameFile$, ia%, 1) = "/" Then

             NameFile$ = Right$(NameFile$, (L% - ia%))

             Exit For

          End If

      Next ia%

      NAM$ = ""

      EXT$ = ""

      p% = InStr(NameFile$, ".")

      L% = Len(NameFile$)

      If p% = 0 Then

         NAM$ = NameFile$

      Else

         NAM$ = Left$(NameFile$, (p% - 1))

         EXT$ = Right$(NameFile$, (L% - p%))

      End If

      ptrF% = ptrF% + 1

      If ptrF% > sz% Then

         ReDim Preserve Fnames(1 To sz% + 300) As String

         sz% = sz% + 300

      End If

      Fnames(ptrF%) = NAM$ + "." + EXT$

      PZip& = PZip& + LL&

      Seek ZIP%, PZip& + 1

   Loop

   Close ZIP%

   ReDim Preserve Fnames(1 To ptrF% - 1) As String

   ZipCont = Fnames

End Function

Public Function CVI(CC As String)

Dim PP As Integer

    PP = 0

    For i% = 2 To 1 Step -1

        C1$ = Mid$(CC, i%, 1)

        PP = PP * 256 + Asc(C1$)

    Next i%

    CVI = PP

End Function

Public Function CVL(CC As String)

Dim PP As Long

    PP = 0

    For i% = 4 To 1 Step -1

        C1$ = Mid$(CC, i%, 1)

        PP = PP * 256 + Asc(C1$)

    Next i%

    CVL = PP

End Function

Sub Test()

Dim ZipArc() As String

    zipName$ = "C:\sv00.zip"

    ZipArc = ZipCont(zipName$)

    For i% = 1 To UBound(ZipArc, 1)

        Debug.Print ZipArc(i%)

    Next i%

End Sub

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

'***************************************************************

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub CopyFileToArchiv(ZipName As String, FileName As String)

' ZipName - полный путь к архиву

' FileName - полный путь к архивируемому файлу

Dim ShellApp As Object

Dim DestFolder As Object

      Set ShellApp = CreateObject("Shell.Application")

      Set DestFolder = ShellApp.NameSpace((ZipName))

      ' копируемый выбранный файл в zip папку

     DestFolder.CopyHere (FileName)

      ' ожидаем окончание сжатия файла

     Do Until DestFolder.Items.Count = 1

           Sleep 100

      Loop

      Set ShellApp = Nothing

End Sub

'*

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

Public Function fnNameArchiveFile(ZipName As String, Optional i As Integer = 0, _

Optional fext As Boolean = True) As String

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

' i - номер файла в архиве (начало с 0), по умолчанию - 0

' fext - включать расширение в имя файла, по умолчанию - true

Dim objShellApp As Object

Dim objFolder As Object

      Set objShellApp = CreateObject("Shell.Application")

      Set objFolder = objShellApp.NameSpace((ZipName))

      If fext Then

           fnNameArchiveFile = objFolder.Items().Item((i)).Path

      Else

           fnNameArchiveFile = objFolder.Items().Item((i)).Name

      End If

End Function

1

2

3

4

5

6

7

8

9

10

11

12

Public Sub UnZipFile(ZipName As String, DestPath As String)

' ZipName - полный путь к архиву

' DestPath - полный путь к папке для распаковки архива

Dim ShellApp As Object

      Set ShellApp = CreateObject("Shell.Application")

      'Copy the files in the newly created folder

     ShellApp.NameSpace((DestPath)).CopyHere ShellApp.NameSpace((ZipName)).Items

      Set ShellApp = Nothing

End Sub

Function ArjCont(ArcName As String) As String()

Dim Fnames() As String

   ReDim Fnames(1 To 300) As String

   sz% = 30

   Arj% = FreeFile

   Open ArcName For Binary Access Read As #Arj%

   OO& = 1

   NE% = 0

   Do

      Seek #Arj%, OO&

      Signature$ = "  "

      Get #Arj%, , Signature$

      If Signature$ <> Chr$(&H60) + Chr$(&HEA) Then

         Close #Arj%

         ReDim Fnames(1 To 1) As String

         ArjCont = Fnames

         Exit Function

      End If

      LL$ = " "

      Get #Arj%, , LL$

      LL_& = Asc(LL$)

      If LL_& = 0 Then Exit Do

      BUF$ = Space$((LL_& + 7))

      Get #Arj%, , BUF$

      NameFile$ = ""

      For i% = 32 To Len(BUF$)

          S$ = Mid$(BUF$, i%, 1)

          If S$ = Chr$(0) Then Exit For

          NameFile$ = NameFile$ + S$

      Next i%

      If NE% > 0 Then

         ptrF% = ptrF% + 1

         If ptrF% > sz% Then

            ReDim Preserve Fnames(1 To sz% + 300) As String

            sz% = sz% + 300

         End If

         Fnames(ptrF%) = NameFile$

      End If

      C4$ = Mid$(BUF$, 14, 4)

      LF& = CVL(C4$)

      If NE% = 0 Then

         OO& = OO& + (LL_& + 10)

      Else

         OO& = OO& + (LL_& + 10 + LF&)

      End If

      NE% = NE% + 1

   Loop

   Close Arj%

   ReDim Preserve Fnames(1 To ptrF%) As String

   ArjCont = Fnames

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

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

59

60

61

62

63

64

65

66

67

68

69

70

71

72

73

74

75

76

77

78

79

80

81

82

83

84

85

86

87

88

89

90

91

92

93

94

95

96

97

98

99

100

'/// Класс создания ZIP-файла средствами Windows

'/// Автор: ALX_2002

'/// Пример работы с классом

Set FileSytemObject = CreateObject("Scripting.FileSystemObject")

'/// Получаем путь до каталога в котором находимся

ParentFolderName = FileSytemObject.GetParentFolderName(Wscript.ScriptFullName)

'/// Строим путь для создания тестового файла

SourceFilePath = FileSytemObject.BuildPath(ParentFolderName,"Текстовый документ.txt")

'/// Создаём и заполняем файл содержимым

FileSytemObject.OpenTextFile(SourceFilePath,2,True).write "Содержимое файла"

'/// Создаём архив

DestFilePath = FileSytemObject.BuildPath(ParentFolderName,"1.zip")

'/// Создаём класс создания ZIP файла

Set Zip = New ZipClass

'/// Открываем новый архив

Zip.CreateArchive DestFilePath

'/// Добавляем файл в архив

Zip.CopyFileToArchive SourceFilePath

'/// Закрываем архив

Zip.CloseArchive

MsgBox "Архив создан",vbInformation,"ZipClass"

'/// Код класса

Class ZipClass

        Private Shell

        Private FileSystemObject

        Private ArchiveFolder

        Private ItemsCount

        Private Sub Class_Initialize()

            Set Shell = CreateObject("Shell.Application")

            Set FileSystemObject = CreateObject("Scripting.FileSystemObject")

        End Sub

        Function CreateArchive(ZipArchivePath)

            If UCase(FileSystemObject.GetExtensionName(ZipArchivePath)) <> "ZIP" Then

                Exit Function

            End If

            Dim ZipFileHeader

            ZipFileHeader = "PK" & Chr(5) & Chr(6) & String(18, 0)

            FileSystemObject.OpenTextFile(ZipArchivePath, 2, True).Write ZipFileHeader

            Set ArchiveFolder = Shell.NameSpace(ZipArchivePath)

                if Not (ArchiveFolder is Nothing) Then CreateArchive = True

        End Function

        Function CopyFileToArchive(FilePath)

                if (ArchiveFolder is Nothing) Then Exit Function

            ArchiveFolder.CopyHere FilePath

                ItemsCount = ItemsCount + 1

        End Function

        Function CopyFolderToArchive(FolderPath)

                if (ArchiveFolder is Nothing) Then Exit Function

            ArchiveFolder.CopyHere FolderPath

                ItemsCount = ItemsCount + 1

        End Function

        Function CloseArchive

                if (ArchiveFolder is Nothing) Then Exit Function

                Set WsriptShell = CreateObject("Wscript.Shell")

      if IsObject(Wscript) Then

         Do

            Wscript.Sleep 100

                    Loop Until ArchiveFolder.Items.Count => ItemsCount

      Else

         ServerSleep

      End if

           ItemsCount = 0

        End Function

   Private Function ServerSleep

                Set WsriptShell = CreateObject("Wscript.Shell")

      Do

         WsriptShell.Popup "",1,""

                Loop Until ArchiveFolder.Items.Count => ItemsCount

   End Function

        Function MoveFileToArchive(FilePath)

                if (ArchiveFolder is Nothing) Then Exit Function

            ArchiveFolder.MoveHere FilePath

        End Function

End Class