Архивирование структуры папок

[eda]

Скажите, пожалуйста, как решить следующую задачу:
Есть список файлов с одним именем. Нужно заархивировать их вместе со структурой папок, в которых они хранятся, т.е. в архиве восоздать структуру папок для каждого файла, при этом в архив не должны попадать файлы, которых нет в списке, но есть в папках. Очень срочно!

[eda]

Есть следующий код:

Private Function ZipFiles(ByVal prjID As String, _ 
                          ByVal Performer As String, _ 
                          ByRef FileList() As Long, _ 
                 Optional ByVal Silent As Boolean = True) As String 
ZipFiles = vbNullString 

Dim aSheet          As Excel.Worksheet 
Dim tmpRow          As Long 
Dim tmpStr1         As String 
Dim tmpStr2         As String 

'настройки ZIP: 
Dim tgtFiles        As ZIPnames 
Dim zipOpt          As ZPOPT 
Dim zipCBs          As ZIPUSERFUNCTIONS 

'Имена дисков, файлов и папок: 
Dim QADir           As String  'Адрес папки QA текущего проекта. 

Dim SysDrv          As String  'Имя системного диска. 
Dim ID              As String  'Уникальный идентификатор, входящий в имя папки/архива. 
Dim oD              As String  'Имя временной выходной папки. 
Dim aN              As String  'Имя архива. 
Dim folder          As String  'Полное имя к каждому конкретному файлу для архивирования. 

Dim Group           As String  'Имя группы исполнителя. 
Dim GroupFolder     As String  'Имя папки группы исполнителя. 
Dim PerfFolder      As String  'Имя папки исполнителя. 

Dim RetCode         As Long 
Dim i               As Long 
Dim j               As Long 
Dim k               As Long 

Dim PrepareOK       As Boolean 

Dim ArchOK          As Boolean 
Dim ErrButExists    As Boolean 
Dim answer          As VbMsgBoxResult 

PrepareOK = False   ' <-- подготовка к архивированию начата 

Set aSheet = Excel.ActiveSheet 

QADir = Excel.ActiveWorkbook.path & WIN_PATH_DLM    ' Адрес папки QA. 
SysDrv = Environ("Temp")                            ' Имя диска. 
ID = IIf(Not Len(prjID) = 0, prjID & "-" & Format(Date, "yyyy.mm.dd"), TASK_PREFIX & "-" & Format(Date, "yyyy.mm.dd")) 

Dim oFS As New Scripting.FileSystemObject 
Group = GetCurrentTaskType() 

Dim sGrpFolder As String: sGrpFolder = ToFolderName(Group) 
GroupFolder = QADir & ".." & WIN_PATH_DLM & sGrpFolder 

If Not oFS.FolderExists(GroupFolder) Then MkDir GroupFolder 
PerfFolder = GroupFolder & WIN_PATH_DLM & Performer 

If Not oFS.FolderExists(PerfFolder) Then MkDir PerfFolder 
aN = PerfFolder & WIN_PATH_DLM & ID & ARCHIVE_EXT 

GroupFolder = QADir & ".." & WIN_PATH_DLM & FromFolderName(Group) 
If Not oFS.FolderExists(GroupFolder) Then MkDir GroupFolder 

PerfFolder = GroupFolder & WIN_PATH_DLM & Performer 
If Not oFS.FolderExists(PerfFolder) Then MkDir PerfFolder 

Excel.Application.Cursor = xlWait 
Excel.Application.StatusBar = "Идет архивирование задания..." 

    NewZip (aN) 

Dim oApp As Object 
Set oApp = CreateObject("Shell.Application") 
Dim copiedFiles As New Dictionary 

k = -1 
With aSheet.Hyperlinks 
    'On Error GoTo Cleanup 
    PrepareOK = True ' <-- подготовка к архивированию окончена 
    ArchOK = False 
    For i = 1 To .count 
        If .item(i).Range.Column = COL_FILE Then 
            tmpRow = .item(i).Range.row 
            For j = 1 To UBound(FileList) 
                If tmpRow = FileList(j) Then 
                    If copiedFiles.Exists(.item(i).name) Then 
                        MsgBox "Попытка повторно записать в архив файл с именем " & .item(i).name & vbCrLf & "Внимание! В архиве нет структуры папок, поэтому архивируйте файлы с совпадающими именами отдельно!" 
                        GoTo Cleanup 
                    Else 
                        ' Добавим в коллекцию. 
                        copiedFiles.Add .item(i).name, i 
                        ' Вычислим путь к этому файлу 
                        tmpStr1 = IIf((Left(.item(i).Address, 2) = "\\") Or (Mid(.item(i).Address, 2, 2) = ":\"), .item(i).Address, QADir & .item(i).Address) 
                        If oFS.FileExists(tmpStr1) Then 
                            k = k + 1                            
                            ' 1. Copy the file to the compressed folder 
                            tmpStr1 = Replace(tmpStr1, "/", "\") 
                            oApp.Namespace(aN & "\").CopyHere CStr(tmpStr1) 
                        Else 
                            MsgBox "Файл с полным именем" & vbCrLf & vbCrLf & _ 
                                   tmpStr1 & vbCrLf & vbCrLf & _ 
                                   "не существует.", vbExclamation, "Файл не найден" 
                        End If 
                    End If 
                    Exit For 
                End If 
            Next j 
        End If 
    Next i 
    
    If k = -1 Then 
        MsgBox "Невозможно заархивировать ни один файл.", vbCritical, "Ошибка" 
        GoTo Cleanup 
    End If 
    
    Excel.Application.Cursor = xlDefault 
    Excel.Application.StatusBar = False 
    ArchOK = True 

Set oApp = Nothing 
End With 

UnIni: 
Set aSheet = Nothing 
End Function

Его нужно исправить в соответствии с задачей, описанной выше. Помогите пожалуйста!

[EducatedFool]

Нужно заархивировать их вместе со структурой папок, в которых они хранятся, т.е. в архиве восоздать структуру папок для каждого файла, при этом в архив не должны попадать файлы, которых нет в списке, но есть в папках.

Это легко реализуется средствами WinRAR.
Впрочем, WinRAR-ом можно управлять и из макроса.

Вряд ли Вы получите готовое решение, если не объясните, где брать путь к архивируемой папке, и список архивируемых файлов.

[eda]

Сообщение от EducatedFool

Вряд ли Вы получите готовое решение, если не объясните, где брать путь к архивируемой папке, и список архивируемых файлов.

почему? разве нельзя с какими-нибудь тестовыми каталогами и файлами? я, возможно, не поняла вопроса... Они могут быть жестко вшиты в код. Мне скорее важно, как это можно сделать без вызова winzip как внешней программы.

[EducatedFool]

разве нельзя с какими-нибудь тестовыми каталогами и файлами?

Конечно, можно.
Только Вы же потом заявите: а у меня список файлов в другом виде, а у меня путь к папке постоянно меняется, и т.д.
И что, нам каждый раз переписывать макрос?

Нет уж, так дело не пойдёт.
Макрос нужен всё-таки Вам, а не нам.
Так что будьте добры подробно сформулировать задание: откуда брать файлы, где искать список файлов для архивации (и в каком виде этот список - текстовый файл, или диапазон ячеек на листе), где создавать архив.
Желательно прикрепить примеры файла-списка, и папки с подпапками (для архивации)

[eda]

В прикрепленном файле в поле Path видно, что у файлов есть общая папка Target_Ru. Вот ее структуру и и файлы, которые расположены в столбце File, нужно заархивировать. Путь к архиву - строковая константа "C:\Documents and Settings\npavlovich\Application Data\Microsoft\AddIns".
Папка Target_Ru и путь к ней не меняются.