Private Function FindFiles(Files As Collection, ByVal Recurse As Boolean)
'Finds all the files matching the specification
'*******************************************
'RECURSIVE FOLDER SEARCH NOT YET IMPLEMENTED
'*******************************************
Dim Result As New Collection
Dim i As Long
For i = 1 To Files.Count
Debug.Print Files(i)
'Parse the file specification to find the path
Path = ParsePath(Files(i))
'Find the files matching the pattern
r = Dir$(Files(i), Attributes)
Do Until r = ""
'Add the file to the new file list collection
Result.Add Path & r
'Move on to next file, if one exists
r = Dir$()
Loop
Next i
Set FindFiles = Result
End Function
Public Function Add(Files As Collection, ByVal Action As ZipAction, ByVal StorePathInfo As Boolean, ByVal RecurseSubFolders As Boolean, ByVal UseDOS83 As Boolean, ByVal CompressionLevel As ZipLevel) As Long
'Adds the specified files to the archive
Dim ArchiveFilename As String
ArchiveFilename = ZipFilename
Dim i As Long
Dim Result As Long
Dim FilesToAdd As Collection
'Check to see if there are any files in the archive
'if not delete the file so there are not error messages
If GetEntryNum = 0 Then
If Dir$(ArchiveFilename) <> "" Then
Kill ArchiveFilename
End If
End If
'Find all the files to add, recursing folders if selected
Set FilesToAdd = FindFiles(Files, RecurseSubFolders)
'Loop through the files adding them to the archive
For i = 1 To FilesToAdd.Count
Debug.Print "Trying to Add " & FilesToAdd(i)
RaiseEvent OnZipProgress((100 * (i / (FilesToAdd.Count))), ParseFilename(FilesToAdd(i)))
DoEvents
If AddFile(ArchiveFilename, FilesToAdd(i), StorePathInfo, UseDOS83, Action, CompressionLevel) Then
'File successfully extracted
Result = Result + 1
Else
'File did not extract for some reason
End If
Next i
RaiseEvent OnZipComplete(Result)
'If any file was added update the archive
If Result > 0 Then
Read
RaiseEvent OnArchiveUpdate
End If
End Function
Public Function Delete(Files As Collection) As Long
'Deletes the files specified in the collection
'Returns the number of files deleted
Dim FilesToDelete As Collection
Dim ArchiveFilename As String
ArchiveFilename = ZipFilename
Dim i As Long
Dim Result As Long
'First find the files which match the patterns
'specified in the collection
Set FilesToDelete = SelectFiles(Files)
'Extract each file in turn
For i = 1 To FilesToDelete.Count
Debug.Print "Trying to Delete " & FilesToDelete(i)
RaiseEvent OnDeleteProgress((100 * (i / (FilesToDelete.Count))), ParseFilename(FilesToDelete(i)))
DoEvents
'Check to see if we are deleting the last entry
'if so just delete the archive
If (GetEntryNum - Result) > 1 Then
If DeleteFile(ArchiveFilename, FilesToDelete(i)) Then
'File successfully extracted
Result = Result + 1
Else
'File did not extract for some reason
End If
Else
Kill ArchiveFilename
Result = Result + 1
End If
Next i
RaiseEvent OnDeleteComplete(Result)
'If any file was deleted update the archive
If Result > 0 Then
Read
RaiseEvent OnArchiveUpdate
End If
Delete = Result
End Function
Public Function Extract(Files As Collection, ByVal Action As ZipAction, ByVal UsePathInfo As Boolean, ByVal Overwrite As Boolean, ByVal Path As String) As Long
'Extracts the files specified in the collection
'Returns the number of files extracted
Dim FilesToExtract As Collection
Dim ArchiveFilename As String
ArchiveFilename = ZipFilename
Dim i As Long
Dim Result As Long
'First find the files which match the patterns
'specified in the collection
Set FilesToExtract = SelectFiles(Files)
'Check to if there is anything to do
'if there is create the output path if it does not exist
'************
'TO IMPLEMENT
'************
'Extract each file in turn
For i = 1 To FilesToExtract.Count
Debug.Print "Trying to Extract " & FilesToExtract(i) & " to " & Path
RaiseEvent OnUnzipProgress((100 * (i / (FilesToExtract.Count))), ParseFilename(FilesToExtract(i)))
DoEvents
If ExtractFile(ArchiveFilename, CStr(FilesToExtract(i)), Path, UsePathInfo, Overwrite, Action) Then
'File successfully extracted
Result = Result + 1
Else
'File did not extract for some reason
End If
Next i
RaiseEvent OnUnzipComplete(Result)
Extract = Result
End Function
Public Property Get Filename() As String
Filename = ZipFilename
End Property
Public Property Let Filename(ByVal New_Filename As String)
Dim r As Long
Dim i As Long
'Called when the filename is updated
ZipFilename = New_Filename
PropertyChanged "Filename"
'Read in the contents of the file
r = Read
'Raise the update event
RaiseEvent OnArchiveUpdate
End Property
Public Function GetEntry(ByVal Index As Long) As ZipFileEntry
Set GetEntry = Archive(Index)
End Function
Public Function GetEntryNum() As Long
GetEntryNum = Archive.Count
End Function
Private Function SelectFiles(Files As Collection) As Collection
'Selects files from a wildcard specification
'Wildcards only corrispond to the filename and not the path
Dim i As Long
Dim j As Long
Dim Result As New Collection
'Loop through the collection looking at each entry
For i = 1 To Files.Count
'Loop through the files in the archive checking the pattern
For j = 1 To GetEntryNum()
'Check the pattern, ignoring case
If LCase$(ParseFilename(GetEntry(j).Filename)) Like LCase$(Files(i)) Then
'Its a match so add it to the new collection
Result.Add GetEntry(j).Filename
End If
Next j
Next i
Set SelectFiles = Result
End Function
Public Function ParsePath(Path As String) As String
'Takes a full file specification and returns the path
For A = Len(Path) To 1 Step -1
If Mid$(Path, A, 1) = "\" Or Mid$(Path, A, 1) = "/" Then
'Add the correct path separator for the input
If Mid$(Path, A, 1) = "\" Then
ParsePath = LCase$(Left$(Path, A - 1) & "\")
Else
ParsePath = LCase$(Left$(Path, A - 1) & "/")
End If
Exit Function
End If
Next A
End Function
Public Function ParseFilename(ByVal Path As String) As String
'Takes a full file specification and returns the path
For A = Len(Path) To 1 Step -1
If Mid$(Path, A, 1) = "\" Or Mid$(Path, A, 1) = "/" Then
ParseFilename = Mid$(Path, A + 1)
Exit Function
End If
Next A
ParseFilename = Path
End Function
Private Sub UserControl_Initialize()
'Create a new Archive Collection
Set Archive = New Collection
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
