'Как программно организовать не прибегая к созданию файла CMD... BAT

'

'1. Наличие файла в архиве ?

'2. Извлечения из архива ?

'3. Добавление в архив ?

'

'какие типы для этого использовать ZIP RAR COM TAR....

'==========================================================================================

'##### И з в л е ч е н и е !***************************************************************

Sub test_UnZipFile()

'ZipName = "D:\Public\Documents\SaveAttachOutlook\2013-02-12_19-25_V3+V2+V1.zip"

DestPath = "D:\Public\Documents\SaveAttachOutlook\"

Call EventsChange(False)

On Error Resume Next

With Application.FileDialog(msoFileDialogOpen)

.ButtonName = "Выбрать":

.Title = "Выбрать архив (*.zip)":

.InitialFileName = DestPath

.Filters.Clear: .Filters.Add "Архивы zip", "*.zip*"

If .Show <> -1 Then Exit Sub

ZipName = .SelectedItems(1): PS = Application.PathSeparator

For Each oFl In .SelectedItems

' Debug.Print oFl

ZipName = oFl

If Len(ZipName) > 0 Then

'старое имя

m = Split(fnNameArchiveFile(ZipName), "\", -1, vbTextCompare) 'имя файла в архиве

sFileName = m(UBound(m))

'формируем новое имя

m = Split(m(UBound(m) - 1), ".", -1, vbTextCompare)

sZipName = m(LBound(m))

m = Split(sFileName, ".", -1, vbTextCompare)

strExt = m(UBound(m))

'распаковать

Call UnZipFile(ZipName, "D:\Public\Documents\Temp\")

'переименовать файл

Call Rename_File("D:\Public\Documents\Temp\" & sFileName, DestPath & sZipName & "." & strExt)

Debug.Print oFl & " =>> " & DestPath & sZipName & "." & strExt

End If

Next

End With

Call EventsChange(True)

End Sub

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

Sub Rename_File(ByVal sFileName As String, ByVal sNewFileName As String)

' Dim sFileName As String, sNewFileName As String

' sFileName = "C:\WWW.xls" 'имя исходного файла

' sNewFileName = "C:\WWW1.xls" 'имя файла для переименования

On Error Resume Next

If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub

Kill sNewFileName

Name sFileName As sNewFileName 'переименовываем файл

' MsgBox "Файл переименован", vbInformation, "www.excel-vba.ru"

End Sub

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

Public Sub UnZipFile(ByVal ZipName As String, ByVal 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 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

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

'Вот мой довольно старый код получения оглавления zip-архива:

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

'Запись в архив !

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

'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

'*

'Так можно узнать имена фaйлов в ZIP-архиве !

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

Public Function fnNameArchiveFile(ByVal 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

'А вот так - в Arj-архиве:

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

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

''Из интернетов еще - VBScript Class:

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

''/// Класс создания 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