cbigwrite.cls

WinBig. A file archive utility written in VB. Compression and decompression routines are LZSS. Full

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cBigWrite"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private Const BIG_FILE_ID As String = "RBF1.23"

Private Type big_head
    cookie As String * 7
    toc_size As Long
    header_unknown As Long
End Type

Private Type toc_entry
    Crc64 As Currency
    name_size As Integer
    fill103 As Integer
    data_compressed_size As Long
    data_uncompressed_size As Long
    file_offset As Long
    timestamp As Long
    data_compressed_flag As Byte
    toc_unknown(0 To 2) As Byte
End Type

Private Type file_entry
    Crc64 As Currency
    filename As String
End Type

Private mpbar As Object

Private mcrc_msb As Long
Private mcrc_lsb As Long
Private miFileID As Integer
Private moFileSys As Scripting.FileSystemObject
Private mlCurCnt As Long
Private mlMaxCnt As Long
Private msStartDir As String

Private mheader As big_head
Private mtoc() As toc_entry
Private mFileList() As file_entry
Private oError As cError
Private msubfuncname As String

Private Sub Class_Initialize()
    Set moFileSys = New Scripting.FileSystemObject
    Set oError = New cError

    Call ModCode.Build_CRC32_Table
    Call ModLZSS.InitializeLZSS
    
    mheader.cookie = BIG_FILE_ID
    mheader.header_unknown = 1
End Sub

Private Sub Class_Terminate()
    Set moFileSys = Nothing
End Sub

Public Property Get Error() As cError
    Set Error = oError
End Property

Public Function BuildNewBig(filename As String, InputDir As String, pBar As Object) As Boolean
    On Error GoTo LocalError
    msubfuncname = "BuildNewBig"
    oError.Clear
    
    Dim loFolder As Scripting.Folder
    Dim llx As Long, lly  As Long
    
    BuildNewBig = False
    
    If Dir(filename) <> "" Then Kill filename
    
    msStartDir = InputDir
    Set mpbar = pBar
    
    Set loFolder = moFileSys.GetFolder(InputDir)
    
    CntFiles loFolder
        
    mheader.toc_size = mlMaxCnt
    
    ReDim mtoc(0 To mlMaxCnt - 1)
    ReDim mFileList(0 To mlMaxCnt - 1)
    mpbar.Max = mlMaxCnt
    
    FindFiles loFolder
    
    BubbleSort mFileList
    For lly = 0 To mlMaxCnt - 1
        If mFileList(lly).Crc64 > 0 Then Exit For
    Next lly
    
    miFileID = FreeFile()
    Open filename For Binary Access Write As miFileID
    
    Put miFileID, , mheader
    Put miFileID, , mtoc
    
    ReDim mtoc(0 To 0)
    
    mlCurCnt = 0
    For llx = lly To mlMaxCnt - 1
        ProcessFile llx, mlCurCnt
        mlCurCnt = mlCurCnt + 1
        mpbar.value = mlCurCnt
        mpbar.Refresh
    Next llx
    For llx = 0 To lly - 1
        ProcessFile llx, mlCurCnt
        mlCurCnt = mlCurCnt + 1
        mpbar.value = mlCurCnt
        mpbar.Refresh
    Next llx
    
    Close miFileID

    Erase mtoc
    Erase mFileList
    BuildNewBig = True
    
    Exit Function
LocalError:
    oError.Number = Err.Number
    oError.Description = Err.Description
    Err.Raise oError.Number, msubfuncname, oError.Description
End Function

Private Sub CntFiles(arg1 As Scripting.Folder)
    On Error GoTo LocalError
    msubfuncname = "CntFiles"
    oError.Clear
    
    Dim loFolder As Scripting.Folder
    For Each loFolder In arg1.SubFolders
        CntFiles loFolder
    Next
    
    'mlMaxCnt = mlMaxCnt + arg1.Files.count
    Dim lofile As Scripting.File
    For Each lofile In arg1.Files
        mlMaxCnt = mlMaxCnt + 1
    Next
    
    Exit Sub
LocalError:
    oError.Number = Err.Number
    oError.Description = Err.Description
    Err.Raise oError.Number, msubfuncname, oError.Description
End Sub

Private Sub FindFiles(arg1 As Scripting.Folder)
    On Error GoTo LocalError
    msubfuncname = "FindFiles"
    oError.Clear
    
    Dim loFolder As Scripting.Folder
    For Each loFolder In arg1.SubFolders
        FindFiles loFolder
    Next
    
    Dim lofile As Scripting.File
    For Each lofile In arg1.Files
        mFileList(mlCurCnt).filename = Mid(lofile.Path, Len(msStartDir) + 1)
        mFileList(mlCurCnt).Crc64 = CrcString(mFileList(mlCurCnt).filename)
        
        mlCurCnt = mlCurCnt + 1
        mpbar.value = mlCurCnt
        mpbar.Refresh
    Next
    
    Exit Sub
LocalError:
    oError.Number = Err.Number
    oError.Description = Err.Description
    Err.Raise oError.Number, msubfuncname, oError.Description
End Sub

Private Sub ProcessFile(Filecnt As Long, Cnt As Long)
    On Error GoTo LocalError
    msubfuncname = "ProcessFile"
    oError.Clear
    
    Dim Bytes() As Byte
    Dim OutBytes() As Byte
    Dim FileSize As Long
    Dim lsxorname As String
    
    'xor file name
    Bytes = StrConv(mFileList(Filecnt).filename, vbFromUnicode)
    xor_make Bytes, UBound(Bytes)
    lsxorname = StrConv(Bytes, vbUnicode)
    Erase Bytes
    lsxorname = lsxorname + Chr(0)
    
    'load file into byte array
    Bytes = GetFile(msStartDir + mFileList(Filecnt).filename)
    FileSize = UBound(Bytes) + 1
    If FileSize > 100 Then
        OutBytes = ModLZSS.Compact(Bytes)
        If UBound(OutBytes) > UBound(Bytes) Then
            OutBytes = Bytes
        End If
    Else
        OutBytes = Bytes
    End If
    
    'build table of contents
    mtoc(0).Crc64 = CrcString(mFileList(Filecnt).filename)  ', mtoc(0).crc_msb, mtoc(0).crc_lsb
    
    mtoc(0).name_size = Len(mFileList(Filecnt).filename)
    mtoc(0).fill103 = 103
    
    If (UBound(OutBytes) + 1) < FileSize Then
        mtoc(0).data_compressed_size = UBound(OutBytes) + 1
        mtoc(0).data_uncompressed_size = FileSize
        mtoc(0).data_compressed_flag = 1
    Else
        mtoc(0).data_compressed_size = FileSize
        mtoc(0).data_uncompressed_size = FileSize
        mtoc(0).data_compressed_flag = 0
    End If
        
    mtoc(0).file_offset = LOF(miFileID)
    mtoc(0).timestamp = DateDiff("s", "1/1/70", FileDateTime(msStartDir + mFileList(Filecnt).filename))
    
    'write output
    Seek miFileID, Len(mheader) + (Len(mtoc(0)) * Cnt) + 1
    Put miFileID, , mtoc
    
    Seek miFileID, LOF(miFileID) + 1
    Put miFileID, , lsxorname
    Put miFileID, , OutBytes
    
    'drop arrays
    Erase Bytes
    Erase OutBytes
    
    Exit Sub
LocalError:
    oError.Number = Err.Number
    oError.Description = Err.Description
    Err.Raise oError.Number, msubfuncname, oError.Description
End Sub

Private Function GetFile(filename As String) As Byte()
    On Error GoTo LocalError
    msubfuncname = "GetFile"
    oError.Clear
    
    Dim FileId As Integer
    If Dir(filename) = "" Then Exit Function
    FileId = FreeFile()
    Open filename For Binary Access Read As FileId
    If LOF(FileId) > 0 Then
        ReDim GetFile(0 To LOF(FileId) - 1)
        Get FileId, , GetFile
    Else
        ReDim GetFile(-1 To -1)
    End If
    Close FileId
    
    Exit Function
LocalError:
    oError.Number = Err.Number
    oError.Description = Err.Description
    Err.Raise oError.Number, msubfuncname, oError.Description
End Function

Private Sub BubbleSort(inputArray() As file_entry)
    On Error GoTo LocalError
    msubfuncname = "BubbleSort"
    oError.Clear
    
    Dim lDown As Long, lUp As Long
    For lDown = UBound(inputArray) To LBound(inputArray) Step -1
        For lUp = LBound(inputArray) + 1 To lDown
            If inputArray(lUp - 1).Crc64 > inputArray(lDown).Crc64 Then
                SwapValues inputArray(lUp - 1).Crc64, inputArray(lDown).Crc64
                SwapString inputArray(lUp - 1).filename, inputArray(lDown).filename
            End If
        Next lUp
    Next lDown
    
    Exit Sub
LocalError:
    oError.Number = Err.Number
    oError.Description = Err.Description
    Err.Raise oError.Number, msubfuncname, oError.Description
End Sub