richsoftvbzip.ctl

用VB调用ZIP.dll和unzip.dll实现文件的压缩和解压缩。

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)
    'Get properties out of storage
    ZipFilename = PropBag.ReadProperty("Filename", "")
End Sub


Private Sub UserControl_Resize()
    UserControl.Size 975, 975
End Sub

Public Sub About()
    'Show the about box
    frmAbout.Show 1
End Sub

Public Function Read() As Long
    'Reads the archive and places each file into a collection
    Dim Sig As Long
    Dim ZipStream As Integer
    Dim Res As Long
    Dim zFile As ZipFile
    Dim Name As String
    Dim i As Integer
    
    'If the filename is empty return a empty file list
    If ZipFilename = "" Then
        Read = 0
        'Remove any files still in the list
        For i = Archive.Count To 1 Step -1
            Archive.Remove i
        Next i
        Exit Function
    End If
    
    'Clears the collection
    'begin
    'Archive.Clear;
    For i = Archive.Count To 1 Step -1
        Archive.Remove i
    Next i
    
    'Opens the archive for binary access
    ZipStream = FreeFile
    Open ZipFilename For Binary As ZipStream
    'Loop through archive
    Do While True
        Get ZipStream, , Sig
        'See if the file header has been found
              If Sig = LocalFileHeaderSig Then
                    'Read each part of the file header
                    Get ZipStream, , zFile.Version
                    Get ZipStream, , zFile.Flag
                    Get ZipStream, , zFile.CompressionMethod
                    Get ZipStream, , zFile.Time
                    Get ZipStream, , zFile.Date
                    Get ZipStream, , zFile.CRC32
                    Get ZipStream, , zFile.CompressedSize
                    Get ZipStream, , zFile.UncompressedSize
                    Get ZipStream, , zFile.FileNameLength
                    Get ZipStream, , zFile.ExtraFieldLength
                    'Get the filename
                    'Set up a empty string so the right number of
                    'bytes is read
                    Name = String$(zFile.FileNameLength, " ")
                    Get ZipStream, , Name
                    zFile.Filename = Mid$(Name, 1, zFile.FileNameLength)
                    'Move on through the archive
                    'Skipping extra space, and compressed data
                    Seek ZipStream, (Seek(ZipStream) + zFile.ExtraFieldLength)
                    Seek ZipStream, (Seek(ZipStream) + zFile.CompressedSize)
                    'Add the fileinfo to the collection
                    AddEntry zFile
              Else
              Debug.Print Sig
                If Sig = CentralFileHeaderSig Or Sig = 0 Then
                    'All the filenames have been found so
                    'exit the loop
                    Exit Do
                'End
                Else
                If Sig = EndCentralDirSig Then
                    'Exit the loop
                    Exit Do
                End If
                End If
            End If
        Loop
        'Close the archive
        Close ZipStream
        'Return the number of files in the archive
        Read = Archive.Count

    'Fire the update event
    RaiseEvent OnArchiveUpdate
End Function

Private Sub AddEntry(zFile As ZipFile)
    Dim xFile As New ZipFileEntry
    'Adds a file from the archive into the collection
    '**It does not add entry that are just folders**
    If ParseFilename(zFile.Filename) <> "" Then
        xFile.Version = zFile.Version
        xFile.Flag = zFile.Flag
        xFile.CompressionMethod = zFile.CompressionMethod
        xFile.CRC32 = zFile.CRC32
        xFile.FileDateTime = GetDateTime(zFile.Date, zFile.Time)
        xFile.CompressedSize = zFile.CompressedSize
        xFile.UncompressedSize = zFile.UncompressedSize
        xFile.FileNameLength = zFile.FileNameLength
        xFile.Filename = zFile.Filename
        xFile.ExtraFieldLength = zFile.ExtraFieldLength
    End If
    Archive.Add xFile
End Sub

Private Function GetDateTime(ZipDate As Integer, ZipTime As Integer) As Date
    'Converts the file date/time dos stamp from the archive
    'in to a normal date/time string
    
    Dim r As Long
    Dim FTime As FileTime
    Dim Sys As SYSTEMTIME
    Dim ZipDateStr As String
    Dim ZipTimeStr As String
    
    'Convert the dos stamp into a file time
    r = DosDateTimeToFileTime(CLng(ZipDate), CLng(ZipTime), FTime)
    'Convert the file time into a standard time
    r = FileTimeToSystemTime(FTime, Sys)

    ZipDateStr = Sys.wDay & "/" & Sys.wMonth & "/" & Sys.wYear
    ZipTimeStr = Sys.wHour & ":" & Sys.wMinute & ":" & Sys.wSecond

    GetDateTime = ZipDateStr & " " & ZipTimeStr
End Function
Private Sub UserControl_Terminate()
    'Clean up the Archive
    Set Archive = Nothing
End Sub


Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    'Put properties into storage
    PropBag.WriteProperty "Filename", ZipFilename, ""
End Sub