richsoftvbzip.ctl

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

VERSION 5.00
Begin VB.UserControl RichsoftVBZip 
   BackStyle       =   0  'Transparent
   CanGetFocus     =   0   'False
   ClientHeight    =   975
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   975
   HasDC           =   0   'False
   InvisibleAtRuntime=   -1  'True
   ScaleHeight     =   975
   ScaleWidth      =   975
   ToolboxBitmap   =   "RichsoftVBZip.ctx":0000
   Begin VB.Frame fraBorder 
      Height          =   855
      Left            =   120
      TabIndex        =   0
      Top             =   0
      Width           =   735
      Begin VB.Image imgZip 
         Height          =   480
         Left            =   120
         Picture         =   "RichsoftVBZip.ctx":0312
         Top             =   240
         Width           =   480
      End
   End
End
Attribute VB_Name = "RichsoftVBZip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'==============================================================================
'Richsoft Computing 2001
'Richard Southey
'This code is e-mailware, if you use it please e-mail me and tell me about
'your program.
'
'For latest information about this and other projects please visit my website:
'www.richsoftcomputing.btinternet.co.uk
'
'If you would like to make any comments/suggestions then please e-mail them to
'[e-mail]
'==============================================================================

'Set up the private atrributes
Private ZipFilename As String
Private CompLevel As ZipLevel
Private DOS83Format As Boolean
Private Recurse As Boolean

'Set up the file collection
Private Archive As Collection

'Events
Event OnArchiveUpdate()
Event OnZipProgress(ByVal Percentage As Integer, ByVal Filename As String)
Event OnZipComplete(ByVal Successful As Long)
Event OnUnzipProgress(ByVal Percentage As Integer, ByVal Filename As String)
Event OnUnzipComplete(ByVal Successful As Long)
Event OnDeleteProgress(ByVal Percentage As Integer, ByVal Filename As String)
Event OnDeleteComplete(ByVal Successful As Long)

'Actions
Public Enum ZipAction
    zipDefault = 1
    zipFreshen = 2
    zipUpdate = 3
End Enum

'Compression Level
Public Enum ZipLevel
    zipStore = 0
    zipLevel1 = 1
    zipSuperFast = 2
    zipFast = 3
    zipLevel4 = 4
    zipNormal = 5
    zipLevel6 = 6
    zipLevel7 = 7
    zipLevel8 = 8
    zipMax = 9
End Enum

Public Function ConvertBytesToString(Bytes As Long) As String
    'Turns a number representing the number of bytes
    'into a string, bytes, KB, MB
    
    Select Case (Bytes / 1024)
        Case Is < 0.2
            ConvertBytesToString = Format(Bytes, "###,##0") & " bytes"
        
        Case Is < 512
            ConvertBytesToString = Format(Bytes / 1024, "###,##0.0") + "KB"
            
        Case Else
            ConvertBytesToString = Format(Bytes / (1024 ^ 2), "###,##0.0") + "MB"
            
    End Select
        
End Function
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