Zip.bas

' public domain

Option Explicit

Private Crc32Table&(255)

Private Type ZipHeader
    ver As Integer
    flags As Integer
    compression As Integer
    dos_time As Integer
    dos_date As Integer
    crc32 As Long
    compressed_size As Long
    uncompressed_size As Long
    filename_length As Integer
    extra_field_length As Integer
    fname_ As String
    attrs_ As Long
    pos_ As Long
End Type

Private Sub InitCrc32Table()
    Dim I%, J%, R&, R1&
    For I = 0 To 255
        R = I
        For J = 0 To 7
            R1 = R And 1
            R = (R - R1) / 2
            If R < 0 Then R = R - &H80000000
            If R1 Then R = R Xor &HEDB88320
        Next J
        Crc32Table(I) = R
    Next I
End Sub

Public Function GetCrc32&(A$)
    Dim R&, I%, B As Byte
    If Crc32Table(255) = 0 Then InitCrc32Table
    R = Not 0
    For I = 1 To Len(A)
        B = Asc(Mid(A, I, 1))
        R = (Int(R / 256) And &HFFFFFF) Xor Crc32Table((R Xor B) And &HFF)
    Next I
    GetCrc32 = Not R
End Function

Public Function GetCrc32FromFile&(Path$)
    Dim R&, I&, B As Byte, FL&
    If Crc32Table(255) = 0 Then InitCrc32Table
    FL = FileLen(Path)
    Open Path For Binary Lock Read As #2
    R = Not 0
    For I = 1 To FL
        Get #2, , B
        R = (Int(R / 256) And &HFFFFFF) Xor Crc32Table((R Xor B) And &HFF)
    Next I
    Close #2
    GetCrc32FromFile = Not R
End Function

Private Function GetDosDate%(DT As Date)
    Dim T&
    T = ((Year(DT) - 1980) * 512 + Month(DT) * 32 + Day(DT)) And 65535
    If T >= 32768 Then T = T - 65536
    GetDosDate = T
End Function

Private Function GetDosTime%(DT As Date)
    Dim T&
    T = Hour(DT) * 2048 + Minute(DT) * 32 + Int(Second(DT) / 2)
    If T >= 32768 Then T = T - 65536
    GetDosTime = T
End Function

Private Function Path_GetFileName$(A$)
    Dim P%
    P = InStrRev(A, "\")
    If P > 0 Then
        Path_GetFileName = Mid(A, P + 1)
    Else
        Path_GetFileName = A
    End If
End Function

Private Sub WriteZipHeader(F%, ZH As ZipHeader)
    Put #F, , ZH.ver
    Put #F, , ZH.flags
    Put #F, , ZH.compression
    Put #F, , ZH.dos_time
    Put #F, , ZH.dos_date
    Put #F, , ZH.crc32
    Put #F, , ZH.compressed_size
    Put #F, , ZH.uncompressed_size
    Put #F, , ZH.filename_length
    Put #F, , ZH.extra_field_length
End Sub

Public Sub MakeZip(Zip$, Files$())
    Dim ZHS() As ZipHeader, ZHLen%, I%, J&, FL&, Path$, Name$, B As Byte
    Dim DT As Date, DS&, DL&
    
    On Error Resume Next
    Kill Zip
    On Error GoTo 0
    Open Zip For Binary Lock Write As #1
    ZHLen = UBound(Files) + 1
    ReDim ZHS(ZHLen - 1)
    
    For I = 0 To ZHLen - 1
        Path = Files(I)
        Name = Path_GetFileName(Path)
        FL = FileLen(Files(I))
        DT = FileDateTime(Files(I))
        With ZHS(I)
            .ver = 10
            .flags = 0
            .compression = 0
            .dos_time = GetDosTime(DT)
            .dos_date = GetDosDate(DT)
            .crc32 = GetCrc32FromFile(Path)
            .compressed_size = FL
            .uncompressed_size = FL
            .filename_length = LenB(StrConv(Name, vbFromUnicode))
            .extra_field_length = 0
            .fname_ = Name
            .attrs_ = GetAttr(Path)
            .pos_ = Seek(1) - 1
        End With
        Put #1, , CStr("PK" & Chr(3) & Chr(4))
        WriteZipHeader 1, ZHS(I)
        Put #1, , Name
        Open Path For Binary Lock Read As #2
        For J = 1 To FL
            Get #2, , B
            Put #1, , B
        Next J
        Close #2
    Next I
    
    DS = Seek(1) - 1
    For I = 0 To ZHLen - 1
        Put #1, , CStr("PK" & Chr(1) & Chr(2))
        Put #1, , ZHS(I).ver
        WriteZipHeader 1, ZHS(I)
        Put #1, , CInt(0)
        Put #1, , CInt(0)
        Put #1, , CInt(0)
        Put #1, , ZHS(I).attrs_
        Put #1, , ZHS(I).pos_
        Put #1, , ZHS(I).fname_
    Next I
    DL = (Seek(1) - 1) - DS
    
    Put #1, , CStr("PK" & Chr(5) & Chr(6))
    Put #1, , CInt(0)
    Put #1, , CInt(0)
    Put #1, , ZHLen
    Put #1, , ZHLen
    Put #1, , DL
    Put #1, , DS
    Put #1, , CInt(0)
    
    Close #1
End Sub