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

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