Skip to content

Instantly share code, notes, and snippets.

@7shi
Created Sep 10, 2010
Embed
What would you like to do?
' 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment