Формирование списка файлов с последующей упаковкой в архив

Option Explicit
 
Private Sub Command1_Click()
    Const BIF_RETURNONLYFSDIRS = 1&
    Dim FSO As Object, FilesList As String, DDF As String, Root As Object, Ext As String, SFX As Boolean
    Dim ff As Integer, ArchName As String, Ret, Output As String
    
    '// Архив создадим на рабочем столе
    Output = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    
    Dim WshFolder As Object
    Set WshFolder = CreateObject("Shell.Application").BrowseForFolder(Me.hWnd, "Select a Folder", BIF_RETURNONLYFSDIRS)
 
    Ext = InputBox("Введите расширение для архивируемых файлов: ")
    ArchName = InputBox("Введите имя архива: ")
    SFX = IIf(MsgBox("Создать самораспаковующийся архив?", vbQuestion + vbYesNo, "CAB") = vbYes, True, False)
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Root = FSO.GetFolder(WshFolder.self.Path)
 
    Ret = GetFiles(Root, LCase(Ext), FilesList)
    If (Ret <> 0) Then Exit Sub
    
    DDF = GetTempFile() '// DDF будет во временной папке Windows
    
    Call CreateDDF(DDF, ArchName, FilesList, Output)
    
    With CreateObject("WScript.Shell")
    
        Ret = .Run("makecab.exe /F " & DDF, 0, True)
        If (Ret <> 0) Then MsgBox "Возникла ошибка при создании архива", vbCritical
    
        If SFX Then '// Магией превращаем обычный архив в самораспаковующийся :)
        
            .Run "cmd /c ""copy /b """ & Environ("windir") & "\system32\extrac32.exe""+""" & _
                Output & "\" & ArchName & ".cab"" """ & Output & "\" & ArchName & ".exe""""", 0, True
        
            Kill Output & "\" & ArchName & ".cab"
        End If
    
    End With
    
    Call Clear(DDF)
    
    Set WshFolder = Nothing: Set Root = Nothing: Set FSO = Nothing
    
    MsgBox "Готово", vbInformation
End Sub
 
Function GetFiles(fold, Ext$, FilesList$)
On Error Resume Next '// Пропуск папок//файлов, защищенных правами
    Dim myfiles As Object, fil
 
    Set myfiles = fold.Files
 
    For Each fil In myfiles
 
        If (LCase(Right(fil.Name, Len(Ext)))) = Ext Then
        
            FilesList = FilesList & """" & fil.Path & """" & vbCrLf
        
        End If
 
    Next
    
    If (Len(FilesList) = 0) Then
        MsgBox "Нет файлов, удовлетворяющих заданным условиям", vbCritical
        GetFiles = 1 '// ErrorLevel
        Exit Function
    End If
    
    FilesList = Left(FilesList, Len(FilesList) - 2) '// -CrLf
    Set myfiles = Nothing
End Function
 
Function GetTempFile() '//// Получить временный незанятый файл
    Dim FSO As Object, FN As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    FN = FSO.GetTempName()
    FN = Environ("temp") & "\" & FN
    
    If Dir(FN) <> vbNullString Then FN = GetTempFile()
 
    GetTempFile = FN
    Set FSO = Nothing
End Function
 
Sub CreateDDF(DDF$, ArchName$, FilesList$, Output$)
    Dim ff As Integer
 
    ff = FreeFile()
    
    '//// Подготовим DDF-файл ответов для архиватора CAB
    Open DDF For Output As #ff
    
        Print #ff, ".Set CabinetNameTemplate=" & ArchName & ".cab"
        Print #ff, ".Set CompressionType=MSZIP"
        Print #ff, ".Set MaxDiskSize=CDROM"
        Print #ff, ".Set ReservePerCabinetSize=6144"
        Print #ff, ".Set Compress=on"
        Print #ff, ".Set CompressionMemory=21"
        Print #ff, ".Set DiskDirectoryTemplate=""."""
        Print #ff, ".Set Cabinet=ON"
        Print #ff, ".Set MaxCabinetSize=999999999"
        Print #ff, ".Set CompressionLevel=7"
        Print #ff, ".Set DiskDirectory1=" & Output
        Print #ff, FilesList
    
    Close #ff
 
End Sub
 
 
Sub Clear(DDF$)
On Error Resume Next
    Kill Environ("temp") & "\setup.inf"
    Kill Environ("temp") & "\setup.rpt"
    Kill Environ("temp") & "\" & DDF
End Sub

Option Explicit
 
' Alex Averchenkoff принадлежит оригинальный код BAT программы MakeCab.
' Dragokas перевел программу на язык Visual Basic 6.
' Dark_Timur исправил и дополнил программу.
' Версия: 1.1
 
Function CreateCab(Source As String, SourceType As String, ArchName As String, Destination As String, Compress As Boolean, _
 CompressLvl As Byte, SubFolders As Boolean, Ext As String, SFX As Boolean, Silent As Boolean) As Long
 
 Dim AddData As String, DDF As String
 
 If LCase(SourceType) = "d" Or LCase(SourceType) = "dir" Or LCase(SourceType) = "directory" Then
  AddData = GetData(Source, True, LCase(Ext), Silent)
 ElseIf LCase(SourceType) = "f" Or LCase(SourceType) = "file" Then
  AddData = """" & Source & """" & vbCrLf
 Else
  If Not Silent Then MsgBox "Неправильно задан тип исходных данных", vbCritical
  CreateCab = 272
  End Function
 End If
 
 If (Err <> 0) Then Exit Function
 DDF = GetTempFile() 'DDF будет во временной папке Windows
 CreateDDF DDF, ArchName, AddData, Destination, IIf(Compress, "ON", "OFF"), CompressLvl
 
 With CreateObject("WScript.Shell")
  
  CreateCab = .Run("makecab.exe /F " & DDF, 0, True)
  If (CreateCab <> 0) Then
   If Not Silent Then MsgBox "Ошибка создания архива (" & CreateCab & ")", vbCritical
   Exit Function
  End If
  
  If SFX Then 'Превращаем обычный архив в SFX
   .Run "cmd /x /c ""copy /b """ & Environ("windir") & "\system32\extrac32.exe""+""" & _
     Destination & "\" & ArchName & ".cab"" """ & Destination & "\" & ArchName & ".exe""""", 0, True
   Kill Destination & "\" & ArchName & ".cab"
  End If
 
 End With
    
 Call Clear(DDF)
 If Not Silent Then MsgBox "Готово.", vbInformation
End Function
 
Function GetData(fold As String, SubFolders As Boolean, Ext As String, Silent As Boolean) As String
On Error Resume Next 'Пропуск папок/файлов, защищенных правами
 Dim myfiles As Object, mydirs As Object
 Dim fil As Object, dir As Object
 
 With CreateObject("Scripting.FileSystemObject").GetFolder(fold)
  Set myfiles = .Files
  Set mydirs = .SubFolders
 End With
 
 For Each fil In myfiles
  If Trim(Ext) = "*" Or Trim(Ext) = "*.*" Or Trim(Ext) = "" Or (LCase(Right(fil.Name, Len(Ext)))) = Ext Then
   GetData = GetData & """" & fil.Path & """" & vbCrLf
  End If
 Next
 
 If SubFolders Then
  For Each dir In mydirs
   GetData = GetData & ".Set DestinationDir=" & Chr(34) & dir.Name & Chr(34) & vbCrLf & _
    GetData(dir.Path, True, Ext, Silent) & vbCrLf
  Next
 End If
 
 GetData = Left(GetData, Len(GetData) - 2) 'CrLf
 Set myfiles = Nothing: Set mydirs = Nothing
End Function
 
Function GetTempFile() 'Получить временный незанятый файл
 Dim FSO As Object, FN As String
    
 Set FSO = CreateObject("Scripting.FileSystemObject")
    
 FN = FSO.GetTempName()
 FN = Environ("temp") & "\" & FN
    
 If dir(FN) <> vbNullString Then FN = GetTempFile()
 
 GetTempFile = FN
 Set FSO = Nothing
End Function
 
Function CreateDDF(DDF$, ArchName, GetData$, Out, SetCom As String, SetComLvl As Byte)
 Dim ff As Integer
 ff = FreeFile()
 
 'Подготовим DDF-файл ответов для архиватора CAB
 Open DDF For Output As #ff
    
 Print #ff, ".Set CabinetNameTemplate=" & ArchName & ".cab"
 Print #ff, ".Set CompressionType=MSZIP"
 Print #ff, ".Set MaxDiskSize=CDROM"
 Print #ff, ".Set ReservePerCabinetSize=6144"
 Print #ff, ".Set Compress=" & SetCom
 Print #ff, ".Set CompressionMemory=21"
 Print #ff, ".Set DiskDirectoryTemplate=""."""
 Print #ff, ".Set Cabinet=ON"
 Print #ff, ".Set UniqueFiles=ON"
 If LCase(SetCom) = "on" Then Print #ff, ".Set CompressionLevel=" & CStr(SetComLvl)
 Print #ff, ".Set DiskDirectory1=" & Out
 Print #ff, GetData
 Close #ff
 
End Function
 
Sub Clear(DDF$)
On Error Resume Next
 Kill Environ("temp") & "\setup.inf"
 Kill Environ("temp") & "\setup.rpt"
 Kill DDF
End Sub

CreateDDF DDF, ArchName, AddData, Destination, IIf(Compress, "ON", "OFF"), CompressLvl

InputBox "","",DDF

InputBox "","",DDF

CreateCab = .Run("makecab.exe /F """ & DDF & """", 0, True)

Dim ExecObj as object
If Not Silent Then
  Set ExecObj = CreateObject("WScript.Shell").Exec("cmd /c makecab.exe /F """ & DDF & """")
  MsgBox "Ошибка создания архива (" & CreateCab & ")" & vbCrLf & ExecObj.StdOut.ReadAll(), vbCritical
  set ExecObj = Nothing
end if