Planet Source Code Jumbo …e CD Visual Basic 1 to 7/1_2002.ISO/Data/Zips/CODE_UPLOAD13332132001.psc/ArZip.cls

Visual Basic class definition | 2001-01-04 | 24.2 KB | 678 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ArZip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'------------------------------------------------------------------
'Module     : ArZip Class
'Description: Ariel Compression Class
'Release    : 2001 VB6
'Copyright  : ⌐ T De Lange, 2000
'------------------------------------------------------------------
'Credits:
'a) Peter Meier, Planet Source Code for the icon extraction technique
'   in his 'DelRecent' posting
'b) Recursive folder list: Brad V (Planet Source Code)
'   Please see http://www.Planet-Source-Code.com/xq/ASP/txtCodeId.11429/lngWId.1/qx/vb/scripts/ShowCode.htm
'   for details.
'------------------------------------------------------------------
'Notes: Add a reference to Microsoft Scripting Runtime dll
'       in the project references box
'------------------------------------------------------------------
Option Base 1
Option Explicit
DefLng A-N, P-Z
DefBool O

'----------------------------------------------------------
'Private Constants
'----------------------------------------------------------
Const ModName = "ArielZip Class"
'Icon Sizes in pixels
Private Const LARGE_ICON As Integer = 32    'Icon Size, pixels
Private Const SMALL_ICON As Integer = 16    'Icon size
Private Const MAX_PATH = 260                'Max length of path+file name
Private Const ILD_TRANSPARENT = &H1         'Display icon transparent
Private Const BMP_SIZE As Long = 822        'Size in bytes of icon bitmaps
Private Const CHUNK_SIZE As Long = 1048576  'Chunk size 1Mb to write archive file

'ShellInfo Flags
Private Const SHGFI_DISPLAYNAME = &H200
Private Const SHGFI_EXETYPE = &H2000
Private Const SHGFI_SYSICONINDEX = &H4000 'System icon index
Private Const SHGFI_LARGEICON = &H0       'Large icon
Private Const SHGFI_SMALLICON = &H1       'Small icon
Private Const SHGFI_SHELLICONSIZE = &H4
Private Const SHGFI_TYPENAME = &H400

Private Const BASIC_SHGFI_FLAGS = SHGFI_TYPENAME _
        Or SHGFI_SHELLICONSIZE Or SHGFI_SYSICONINDEX _
        Or SHGFI_DISPLAYNAME Or SHGFI_EXETYPE

'----------------------------------------------------------
'Public Enums
'----------------------------------------------------------
Public Enum ArZipStatus
  azsEmpty          'Empty
  azsReady          'File & Rootfolder specified
  azsCreated        'Zipfile created (ready for extraction)
  azsBusy
End Enum

Public Enum ArSpanOption
  azo1440     '1.44Mb
  azo1400     '1.40Mb
  azo1200     '1.20Mb
  azo1000     '1.00Mb
  azo720      '720kb
  azo700      '700kb
  azo100p     '100% Capacity (Removable drives only)
  azo99p      '99% Capacity     "
  azo98p      '98% Capacity     "
  azo95p      '95% Capacity     "
  azo90p      '90% Capacity     "
End Enum

Private Enum ZLibErrors
  'Positive numbers are normal occasions, neg's are errors
  zlOk = 0
  zlStreamEnd = 1
  zlNeedDict = 2
  zlErrNo = -1
  zlStreamError = -2      'Invalid compression level parameter
  zlDataError = -3        'Input data corrupted
  zlMemError = -4         'Not Enough Memory
  zlBufError = -5         'Not enough space in output buffer
  zlVersionError = -6
End Enum

'----------------------------------------------------------
'Private Type Defs
'----------------------------------------------------------
Private Type SHFILEINFO              'As required by ShInfo
  hIcon As Long
  iIcon As Long
  dwAttributes As Long
  szDisplayName As String * MAX_PATH
  szTypeName As String * 80
End Type

Private Type ArielFile
  Key As String         'Path\File.ext
  Name As String        'Filename including extension, without path
  Ext As String         'File extension
  Path As String        'Path, eg C:\My Documents (to locate file on HDD)
  RelPath As String     'Relative path in archive e.g. \Memos
  Zipped As Boolean     'Has file been zipped already?
  Size As Long          'Original file size
  ZipSize As Long       'Zip size
  Ratio As Single       'Zip ratio 0 to 1
  Modified As Date
  IconKey As String
  Offset As Long        'Offset of file in CURRENT volume
  ChkSum As Byte        'XOR Checksum from original file back to unzipped file
  ChkSumZip As Byte     'XOR Checksum from zipped file write to read
  Selected As Boolean
End Type

Private Type ArHeader
  'Added at the start of each span volume
  'Id As String * 3     'Don't use fixed/variable strings in copymem()
  Major As Integer
  Minor As Integer
  VolNo As Byte         'Span Volume no, starting at 1
  NextVol As Byte       'Indicates another volume follows (1), or not (0)
  ZipSize As Long       'Total zip file size, prior to spanning
  NoFiles As Long       'No of files in archive
  NoIcons As Long       'No of unique icons (bitmaps) in archive
  Offset  As Long       'Offset to start of file list
End Type

Private Type ArFileRec
  Offset As Long
  OrigSize As Long
  ZipSize As Long
  Modified As Date
  ChkSum As Byte
  ChkSumZip As Byte
End Type

'----------------------------------------------------------
'Functions & Procedures
'----------------------------------------------------------
'Functions to extract icons & place them in a picture box
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
    (ByVal pszPath As String, _
    ByVal dwFileAttributes As Long, _
    psfi As SHFILEINFO, _
    ByVal cbSizeFileInfo As Long, _
    ByVal uFlags As Long) As Long

Private Declare Function ImageList_Draw Lib "comctl32.dll" _
    (ByVal himl&, ByVal i&, ByVal hDCDest&, _
    ByVal x&, ByVal y&, ByVal flags&) As Long

'General Kernel.dll functions
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

'Sleep & Timer functions - see Wait()
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

'ZLib 1.1.3 functions
'Private Declare Function CompressDef Lib "zlib.dll" Alias "compress" (Dest As Any, DestLen As Long, Source As Any, ByVal SourceLen As Long) As Long
Private Declare Function Compress Lib "zlib.dll" Alias "compress2" (Dest As Any, DestLen As Long, Source As Any, ByVal SourceLen As Long, ByVal Level As Long) As Long
Private Declare Function Uncompress Lib "zlib.dll" Alias "uncompress" (Dest As Any, DestLen As Long, Source As Any, ByVal SourceLen As Long) As Long

'----------------------------------------------------------
'Private property variables
'----------------------------------------------------------
Private mRootFolder As String
Private mStatus As ArZipStatus
Private mExist As Boolean         'Does a current zip file exist?
Private mZipFileNew As String     'Zip path & file name
Private mZipFile As String     'Current zip file
Private mTempFolder As String     'Scratch area (used to save icon bitmaps)
Private mTempFile As String       'For use only during disk spanning, placed in tempfolder
Private mBackupFile As String     'Used for storage of existing data, during zipping
Private mUnzipFolder As String
Private mElapsedTime As Single
Private mCompressLevel As Integer
Private mSpanning As Boolean      'Must new zip file be spanned?
Private mSpanned As Boolean       'Has current zip file been spanned?
Private mSpanOption As Long       'Span option for new zip file
Private mSpanSize As Long         'Size of selected span option (new file)
Private mTotalZipSize As Long
Private mCancel As Boolean        'Used to cancel zip/unzip operation

'----------------------------------------------------------
'Events
'----------------------------------------------------------
Public Event StatusChange(NewStatus As ArZipStatus)
Public Event Progress(Value As Single, Info As String)
Public Event ChangeDisk(Drive As Drive, Message As String, File As String)

'----------------------------------------------------------
'Private variables
'----------------------------------------------------------
Private ShInfo As SHFILEINFO
Private mLvwFiles As ListView
Private mIml As ImageList                 'Imagelist containing small icons
Private mPic As PictureBox                'Temporay container for small icon
Private mPicDef As PictureBox             'Default picture for <None> icons
Private mFso As New FileSystemObject      'File system object
Private aFiles() As ArielFile             'Array of files
Private nFiles As Long                    'No of files in array
Private mProgress As Single               'Progress 0 to 1
Private nIcons As Long                    'No of unique icons
Private nPos As Long                      'Temporary posistion in archive file
Private Function AddByte(ByRef Bytes() As Byte, Value As Byte) As Long
'---------------------------------------------------------------------
'Add a byte value to the byte array
'---------------------------------------------------------------------
Dim ns

On Error Resume Next
ns = UBound(Bytes)
If ns = 0 Then
  ReDim Bytes(1) As Byte      'Necessary, to get rid of 0 lower bound
Else
  ReDim Preserve Bytes(ns + 1) As Byte
End If
Call CopyMem(Bytes(ns + 1), Value, 1)
AddByte = UBound(Bytes)

End Function

Private Function AddFile(ByRef File As File) As Boolean
'---------------------------------------------------------------
'Adds a file to the array
'Returns true if successful
'---------------------------------------------------------------
'Notes
'a) The file to be included is validated for existence at source
'   and if it is not the current archive file (or spanned volume)
'b) If it already is in the list (and even in the archive) the
'   file is 'freshened' with the current source info. I.e. by
'   default the source file is to be considered a later/newer
'   version. The zipped flag is set to false to prevent the
'   current zipped version being included in the archive.
'---------------------------------------------------------------
Dim Ok, n

Ok = ValidateFile(File)
If Ok Then
  n = FileInList(File)
  If n = 0 Then
    'Add file to the list
    nFiles = nFiles + 1
    ReDim Preserve aFiles(nFiles) As ArielFile
    n = nFiles
    aFiles(n).ZipSize = File.Size       'Keep the same as original size for now
    aFiles(n).Ratio = 1
    aFiles(n).Zipped = False
  Else
    'Freshen file
    aFiles(n).Zipped = False
  End If
  aFiles(n).Name = File.Name
  aFiles(n).Modified = File.DateLastModified
  aFiles(n).Size = File.Size
  aFiles(n).Path = File.ParentFolder
  aFiles(n).RelPath = RelPath(File.ParentFolder, mRootFolder)
  aFiles(n).Ext = FileExtension(File.Name)
  aFiles(n).Key = aFiles(nFiles).RelPath & "\" & aFiles(nFiles).Name
  aFiles(n).IconKey = GetIconKey(File)
  AddFile = True
Else
  AddFile = False
End If

End Function
Private Function AddBlankFileRecords(Bytes() As Byte) As Long
'---------------------------------------------------
'Add an empty file header to the byte array for
'each file
'a) This to be updated later
'b) The string portions are added in a separater sub
'   after the file list has been written
'Return the ubound() of Bytes()
'---------------------------------------------------
Dim Afr As ArFileRec
Dim ns, n

On Error Resume Next
ns = UBound(Bytes)
n = Len(Afr) * nFiles
If ns = 0 Then
  ReDim Bytes(n) As Byte          'Necessary to get rid of a 0 lower bound
Else
  ReDim Preserve Bytes(ns + n) As Byte
End If
AddBlankFileRecords = UBound(Bytes)

End Function

Private Function AddFileName(Bytes() As Byte, i As Long) As Long
'-----------------------------------------------------------------
'Add the string portion of a file to the byte array
'a) The numeric portions are dealt with separately
'   as they need to be updated at the end of the zip file
'b) All strings are variable length, so add a vbCr at the end
'Return the ubound() of Bytes()
'-----------------------------------------------------------------
On Error Resume Next

AddString Bytes, aFiles(i).Name, True         'File name incl ext
AddString Bytes, aFiles(i).RelPath, True      'Relative path (to rootfolder)
AddString Bytes, aFiles(i).Path, True         'Absolute path
AddString Bytes, aFiles(i).IconKey, True      'Icon key in image list
AddFileName = UBound(Bytes)

End Function

Public Function AddFiles(FileList() As String) As Long
'------------------------------------------------
'Add files to the archive list
'FileList :  Contains the file name(s)
'Return   :  NoFiles added
'------------------------------------------------
'Note: if only 1 file was added, the file
'      path & name is given in element 0
'      if multiselection was done, element 0
'      contains the path and the others the
'      file names, excl path
'------------------------------------------------
Dim Path As String      'Path of files
Dim File As File
Dim i, n, m, Ok

On Error Resume Next
Screen.MousePointer = vbArrowHourglass
SetStatus azsBusy
'mlvwfiles.SmallIcons=nothing
n = UBound(FileList)
If n = 0 Then
  'Single File
  Set File = mFso.GetFile(FileList(0))
  Ok = AddFile(File)
  m = IIf(Ok, 1, 0)
Else
  'Multiple Files
  'Get the path (element 0)
  Path = CheckPath(FileList(0))
  For i = 1 To n
    Set File = mFso.GetFile(Path & FileList(i))
    Ok = AddFile(File)
    If Ok Then m = m + 1
    'DoEvents
  Next
  AddFiles = m          'Set the return parameter
End If
mLvwFiles.SmallIcons = mIml       'Set the smallicons imagelist
Screen.MousePointer = vbNormal
SetStatus azsReady

End Function

Public Function AddFolder(Rootfolder As String, IncludeSubfolders As Boolean) As Long
'---------------------------------------------------------------------------------------------------------------
'Add a folder (and subfolders) to the archive list
'Rootfolder         : Path of folder to add
'IncludeSubfolders  : Include subfolders' contents in the archive
'Return             : Total NoFiles now in list
'---------------------------------------------------------------------------------------------------------------

On Error Resume Next
Screen.MousePointer = vbArrowHourglass
SetStatus azsBusy
ScanTree Rootfolder, IncludeSubfolders    'Recursive tree scan
mLvwFiles.SmallIcons = mIml               'Set the smallicons imagelist
Screen.MousePointer = vbNormal
SetStatus azsReady
AddFolder = nFiles                        'Set the return parameter

End Function

Private Function AddIconRecord(Bytes() As Byte, Bmp() As Byte, Key As String) As Long
'---------------------------------------------------
'Add an icon record (key & bmp) to the Byte array
'Return the ubound() of Bytes()
'---------------------------------------------------
On Error Resume Next

AddString Bytes, Key, True      'Icon key (see imglist)
AddBytes Bytes, Bmp
AddIconRecord = UBound(Bytes)

End Function

Private Function AddInt(ByRef Bytes() As Byte, Value As Integer) As Long
'---------------------------------------------------------------------
'Add integer value to the byte array
'---------------------------------------------------------------------
Dim ns

On Error Resume Next
ns = UBound(Bytes)
If ns = 0 Then
  ReDim Bytes(2) As Byte      'Necessary, to get rid of 0 lower bound
Else
  ReDim Preserve Bytes(ns + 2) As Byte
End If
Call CopyMem(Bytes(ns + 1), Value, 2)
AddInt = UBound(Bytes)

End Function

Private Function AddLong(ByRef Bytes() As Byte, Value As Long) As Long
'---------------------------------------------------------------------
'Add long value to the byte array
'---------------------------------------------------------------------
Dim ns

On Error Resume Next
ns = UBound(Bytes)
If ns = 0 Then
  ReDim Bytes(4) As Byte      'Necessary, to get rid of 0 lower bound
Else
  ReDim Preserve Bytes(ns + 4) As Byte
End If
Call CopyMem(Bytes(ns + 1), Value, 4)
AddLong = UBound(Bytes)

End Function

Private Function AddString(ByRef Bytes() As Byte, ByVal St As String, Optional VarLen As Boolean = False) As Long
'---------------------------------------------------------------------
'Add string St to the byte array
'If VarLen is true, add vbCr to end of string
'Return the ubound (No) of bytes
'---------------------------------------------------------------------
Dim StrBytes() As Byte      '0-based
Dim n, ns

On Error Resume Next
ns = UBound(Bytes)
If VarLen Then St = St & vbCr
StrBytes = StrConv(St, vbFromUnicode)   '0-based
n = Len(St)
If ns = 0 Then
  ReDim Bytes(n) As Byte      'Necessary, to get rid of 0 lower bound
Else
  ReDim Preserve Bytes(ns + n) As Byte
End If
CopyMem Bytes(ns + 1), StrBytes(0), n
AddString = UBound(Bytes)

End Function

Private Sub BackupZipFile()
'-------------------------------------------------------------
'Make a backup of a normal (unspanned) zipfile to the tempfolder
'This is similar to the unspanzipfile() routine
'-------------------------------------------------------------
Dim Drive As Drive          'FSO Drive object
Dim DriveSpec As String     'Required to resolve the drive object
Dim IsFDD As Boolean        'Is destination drive removable?
Dim nfd, nfs                'File Numbers
Dim SourceFile As String    'Name of sourcefile, incl path
Dim DestFile As String      'Complete name of destination file, incl path & ext
Dim nLeft As Long           'Remaining length of file to process
Dim nDest As Long           'Chunck to write
Dim Bytes() As Byte         'Bytes array
Dim SwapDisk As Boolean     'Flag indicating that a disk needs to be inserted/changed
Dim Sum, Total              'Progress indicator
Dim Ans

On Error GoTo BackupZipFileErr
'--------------------------------------------------
'Determine type of drive to read from
'This is necessary since if it is a removable drive
'(i.e. FDD), a dialog must be shown to enter the disk
'--------------------------------------------------
DriveSpec = mFso.GetDriveName(mFso.GetAbsolutePathName(mZipFile))
Set Drive = mFso.GetDrive(DriveSpec)
IsFDD = (Drive.DriveType = Removable)

'---------------------------------------------------
'Get the source file name & initialise other var's
'---------------------------------------------------
SourceFile = mZipFile     'Current zip file
Sum = 0                   'Progress indicators
Total = 0
SetProgress 0, 1, ""

'---------------------------------------------------
'Open the destination file in the temp folder
'---------------------------------------------------
mBackupFile = CheckPath(mTempFolder) & "_Backup.azp"
DestFile = mBackupFile

On Error Resume Next
Kill DestFile                   'Erase file to prevent carry over
On Error GoTo BackupZipFileErr
nfd = FreeFile
Open DestFile For Binary As #nfd

'---------------------------------------------------
'Notes on FDD usage
'---------------------------------------------------
'If a FDD is used, an event is raised indicating to
'the client that the disk needs to be changed. The
'event also indicates which file is required.
'Control should not be returned to this routine
'until a) the correct file has been located or
'      b) the user has cancelled the operation
'Notes
'a) The client must verify the file's existence
'b) The first FDD disk is probably already inserted
'   when the user read the file info. (But it could
'   have been removed in the mean time)
'---------------------------------------------------
'Determine if a disk needs to be changed/inserted
'---------------------------------------------------
StartLoop:
If IsFDD Then
  If Not (Drive.IsReady) Then
    SwapDisk = True
  Else
    SwapDisk = Not (mFso.FileExists(SourceFile))
  End If
  If SwapDisk Then
    'Ask to insert disk
    Screen.MousePointer = vbNormal
    RaiseEvent ChangeDisk(Drive, "Please insert disk with the file " & SourceFile & " into drive " & Drive.DriveLetter, SourceFile)
    Screen.MousePointer = vbArrowHourglass
    DoEvents
    'Allow for client canceling swap disk dialogue
    If mCancel Then
      mCancel = False         'Reset cancel property
      SetStatus azsReady      'Show green light
      Screen.MousePointer = vbNormal
      Exit Sub
    End If  'Cancel
  End If    'SwapDisk
End If      'IsFDD

'-----------------------------------------------------
'Open the source file (spanned volume)
'-----------------------------------------------------
nfs = FreeFile
Open SourceFile For Binary As #nfs

'Repeat this loop until all bytes have been read
nLeft = LOF(nfs) - Loc(nfs)    'Remaining bytes in source
Do
  '-----------------------------------------------------
  'Read a chunk of data
  '-----------------------------------------------------
  SetProgress Sum, Total, "Backing up zip file to hard disk..."
  If nLeft > CHUNK_SIZE Then
    nDest = CHUNK_SIZE
  Else
    nDest = nLeft
  End If
  ReDim Bytes(nDest) As Byte
  Get #nfs, , Bytes

  '-----------------------------------------------------
  'Write chunk of data to destination
  '-----------------------------------------------------
  Put #nfd, Loc(nfd) + 1, Bytes
  nLeft = LOF(nfs) - Loc(nfs)    'Remaining bytes in source
  Sum = Sum + nDest
Loop While nLeft > 0

'-------------------------------------------------------
'Close Files
'-------------------------------------------------------
Close #nfs
Close #nfd
SetProgress Total, Total, ""
Exit Sub

BackupZipFileErr:
Ans = ReportErrorAbort("BackupZipFile()", ModName, Err, Error)
Select Case Ans
Case vbCancel, vbAbort
  Reset       'Closes all files
  Exit Sub
Case vbRetry
  If IsFDD Then
    Close #nfs
    Resume StartLoop
  Else
    Resume
  End If
Case vbOK, vbIgnore
  Resume Next
End Select

End Sub

Property Let Cancel(vCancel As Boolean)
mCancel = vCancel

End Property

Property Get Cancel() As Boolean
Cancel = mCancel

End Property

Property Get Exist() As Boolean
'----------------------------------------------
'Check if a current zip file exists
'----------------------------------------------
Exist = mExist

End Property

Private Function ExtractFile(ByVal i As Long, Bytes() As Byte) As Boolean
'-----------------------------------------------------------------
'Extract a file (no i) from the backed up zip file
'Returns the data in a byte array starting with 1
'If no data is available, then ubound is set to 0
'Returns True if everything went Ok
'-----------------------------------------------------------------
Dim nfs                     'File Numbers
Dim SourceFile As String    'Complete name of source file, incl path & ext
Dim nSource                 'No of bytes to read from source
Dim ChkSum As Byte          'Original Checksum as calculated, for each file
Dim ChkSumZip As Byte       'Zipped checksum
Dim Result As ZLibErrors    'Zlib error code
Dim Ans, n

On Error GoTo ExtractFileErr
'---------------------------------------------------
'Open the source file
'---------------------------------------------------
SourceFile = mBackupFile
nfs = FreeFile
Open SourceFile For Binary As #nfs

'-----------------------------------------------------
'Unzip file
'-----------------------------------------------------
'Get the no of bytes to read for file(i)
nSource = aFiles(i).ZipSize
If nSource > 0 Then
  '-------------------------------------------------
  'Read data for file(i) to unzip
  '-------------------------------------------------
  ReDim Bytes(nSource) As Byte
  n = aFiles(i).Offset          'Get offset position
  Get #nfs, n + 1, Bytes        'Read data to buffer

  '-------------------------------------------------
  'Validate zip checksum
  '-------------------------------------------------
  ChkSumZip = CheckSum(Bytes)
  If ChkSumZip <> aFiles(i).ChkSumZip Then
    Err.Raise 703, "ArZip.UnzipFs(nSo------------ancel prNK_SIZE
  EBp
  aor co"cord =  'NeceD    'Icon Size, p
On Z'
  =  'Nece=  'NeceD    'Icle
'---oReDim Bytes(1) As Byte      'Necessary, to get rid of 0 lower bound
Else
  Rebd of  'Ne
  Erce
Do
 -----------jreturn parametereancena ebd of  'Ne
  Erce

Dim Sum, Total    ----------oAe
'---oReDim Bytes(1) As Byte      'Nalue As Byte) As Lonce

Dim Sum, Total    ----------oAsed indiins the path and thing(1) As