ZIP Compression Using Pure Visual Basic

[rm_03]

I would enjoy it more if someone proves me wrong, though.

I hope you will enjoy this

1) Download the project from the link I posted.
2) Open cls_Zip.cls.
3) Add the following type:

Private Type Pack_Helper_Type
    valid   As Long
    CRC32   As Long
    USize   As Long
    CSize   As Long
    offset  As Long
End Type

4) Overwrite the "pack" function with the following:

Public Function Pack(ZipName As String, files() As String, CompLevel As Integer) As Integer
    Dim CentDat         As Central_Header_Type
    Dim helpers()       As Pack_Helper_Type
    Dim EndCentralSig   As End_Header_Type

    Dim fhIN        As Integer, fhOUT       As Integer
    Dim i           As Integer

    Dim lngSig      As Long, lngCenOff      As Long

    ReDim helpers(LBound(files) To UBound(files))

    fhOUT = FreeFile
    Open ZipName For Binary As #fhOUT

    For i = LBound(files) To UBound(files)
        If Not Trim$(files(i)) = vbNullString Then
            helpers(i) = AppCompFile(fhOUT, files(i), CompLevel)
        End If
    Next

    lngSig = &H2014B50
    lngCenOff = Seek(fhOUT) - 1

    For i = LBound(helpers) To UBound(helpers)
        With CentDat
            .CRC32 = helpers(i).CRC32
            .CSize = helpers(i).CSize
            .offset = helpers(i).offset
            .USize = helpers(i).USize
            .LenFname = Len(GetFile(files(i)))
            .Method = CompLevel
            .VerExt = 20
            .VerMade = 20
        End With
        Put #fhOUT, , lngSig
        Put #fhOUT, , CentDat
        Put #fhOUT, , CStr(GetFile(files(i)))
    Next

    lngSig = &H6054B50

    With EndCentralSig
        .signature = lngSig
        .Entries = UBound(files) - LBound(files) + 1
        .TotEntr = .Entries
        .CenOff = lngCenOff
        .CenSize = Seek(fhOUT) - 1 - lngCenOff
    End With

    Put #fhOUT, , EndCentralSig

    Close #fhOUT

End Function

Private Function AppCompFile(ByVal fh As Integer, ByVal file As String, ByVal level As Integer) As Pack_Helper_Type

    'On Error GoTo OnError

    Dim LocDat                As Local_Header_Type

    Dim fhIN                  As Integer
    Dim btFile()              As Byte

    Dim lngSig                As Long

    AppCompFile.offset = Seek(fh) - 1

    fhIN = FreeFile
    Open file For Binary As #fhIN
        ReDim btFile(LOF(fhIN) - 1) As Byte
        Get #fhIN, , btFile
    Close #fhIN

    LocDat.USize = UBound(btFile) + 1
    LocDat.CRC32 = CRC.CalcCRC32File(btFile)

    Deflate btFile, level, False

    With LocDat
        .CSize = UBound(btFile) + 1
        .LenFname = Len(GetFile(file))
        .Method = level
        .VerExt = 20
    End With

    lngSig = &H4034B50

    Put #fh, , lngSig
    Put #fh, , LocDat
    Put #fh, , CStr(GetFile(file))
    Put #fh, , btFile

    With AppCompFile
        .CRC32 = LocDat.CRC32
        .CSize = LocDat.CSize
        .USize = LocDat.USize
        .valid = 1
    End With

OnError:

End Function

Private Function GetFile(file As String) As String
    GetFile = Mid$(file, InStrRev(file, "\") + 1)
End Function

Example on how to use this function:

Option Explicit

Dim p   As New cls_Zip

Private Sub Form_Load()
    Dim files(0)    As String
    files(0) = "C:\export.def"
    p.Pack "C:\new.zip", files, 8
End Sub

I've done this in about 1 1/2 hours, so you can only add files to the root.
You want a feature, add it.

/edit: Oups, I forgot, you have to add the Deflate module from DreamVB`s link.