UnZIP

Private Function VBUnzip(sFile As String, _
        sExtdir As String, _
        nPrompOverWr As Integer, _
        nAlwaysOverWr As Integer, _
        nVerboseList As Integer, _
        nArgsAreDirs As Integer, _
        colFiles As Collection, _
        colXFiles As Collection) As Boolean
    Dim MYDCL As DCLIST
    Dim MYUSER As USERFUNCTION
    Dim MYVER As UZPVER
    Dim lNumFiles As Long
    Dim vbzipnam As ZIPNAMES
    Dim lNumXFiles As Long
    Dim vbxnames As ZIPNAMES
    Dim X As Long
    
    sZipInfo = ""
    lNumFilesInArchive = 0
    sZipMsg = ""
    vbzipnam.s(0) = vbNullString
    vbxnames.s(0) = vbNullString
    
    If Not colFiles Is Nothing Then
        lNumFiles = colFiles.Count
        For X = 1 To colFiles.Count
            vbzipnam.s(X) = colFiles.Item(X)
        Next X
    End If
    
    If Not colXFiles Is Nothing Then
        lNumXFiles = colXFiles.Count
        For X = 1 To colXFiles.Count
            vbxnames.s(X) = colXFiles.Item(X)
        Next X
    End If
    
    With MYDCL
        .ExtractOnlyNewer = 0
        .SpaceToUnderscore = 0
        .PromptToOverwrite = nPrompOverWr
        .fQuiet = 0
        .ncflag = 0
        .ntflag = 0
        .nvflag = nVerboseList
        .nUflag = 0
        .nzflag = 0
        .ndflag = nArgsAreDirs
        .noflag = nAlwaysOverWr
        .naflag = 0
        .nZIflag = 0
        .C_flag = 0
        .fPrivilege = 0
        .Zip = sFile
        .ExtractDir = sExtdir
    End With
    
    With MYUSER
        .DllPrnt = FnPtr(AddressOf CBDllPrnt)
        .DLLSND = 0&
        .DLLREPLACE = FnPtr(AddressOf CBDllRep)
        If nVerboseList = 1 Then
            .DllMessage = FnPtr(AddressOf CBDllCountFiles)
        End If
    End With
    
    With MYVER
        .structlen = Len(MYVER)
        .beta = Space$(9) & vbNullChar
        .date = Space$(19) & vbNullChar
        .zlib = Space$(9) & vbNullChar
    End With
    
    UzpVersion2 MYVER
    glRet = windll_unzip(lNumFiles, vbzipnam, lNumXFiles, vbxnames, MYDCL, MYUSER)
    
    If glRet <> 0 Then
        MsgBox glRet
        VBUnzip = False
    Else
        VBUnzip = True
    End If
End Function

Public Function InspectZIPArchiveDLL(sFile As String, _
        ByRef lMilliSeconds As Long, _
        ByRef lNumFiles As Long, _
        ByRef dblUnpackedBytes As Double, _
        ByRef dblPackedBytes As Double, _
        lblArchiv As Label) As Boolean
    On Error GoTo ErrExit
    
    Dim sFilename As String
    
    StartTimer
    
    sFilename = sFile
    
    If VBUnzip(sFilename, gsExtractPfad, 0, 0, 1, 1, Nothing, Nothing) Then
        InspectZIPArchiveDLL = True
        lMilliSeconds = MeasureTime
        lNumFiles = lNumFilesInArchive
        dblUnpackedBytes = dblZIPUnpackedBytes
        dblPackedBytes = dblZIPPackedBytes
    End If
    
    Exit Function
    
    ErrExit:
    ShowError
    
    Exit Function
End Function

Public Function FnPtr(ByVal lp As Long) As Long
    FnPtr = lp
End Function

Private Function CBDllPrnt(ByRef tInfo As CBCHAR, ByVal lChars As Long) As Long
    On Error Resume Next
    
    Dim sInfo As String
    Dim X As Long
    Dim nCPos As Long
    
    For X = 0 To lChars
        If tInfo.ch(X) = 0 Then Exit For
        sInfo = sInfo & Chr$(tInfo.ch(X))
    Next X
    sZipInfo = sZipInfo & sInfo
    
    If Asc(sInfo) <> 10 Then
        nCPos = InStr(1, sInfo, vbLf)
        If nCPos > 0 Then
            sInfo = Mid$(sInfo, nCPos + 1)
        End If
        frmPGress2.lblExtractPath.Caption = sInfo
        If frmPGress2.ccrpPGBar.Value < frmPGress2.ccrpPGBar.Max Then
            frmPGress2.ccrpPGBar.Value = frmPGress2.ccrpPGBar.Value + 1
        End If
        
        DoEvents
    End If
    CBDllPrnt = 0
End Function

Private Function CBDllRep(ByRef tFName As CBCHAR) As Long
    On Error Resume Next
    
    Dim sFile As String
    Dim X As Long
    Dim lRet As Long
    
    CBDllRep = 100  ' 100 - do not overwrite - keep asking user
    
    For X = 0 To 255
        If tFName.ch(X) = 0 Then Exit For
        sFile = sFile & Chr$(tFName.ch(X))
    Next X
    
    lRet = MsgBox("Soll die Datei """ & sFile & """ �berschrieben werden?", _
        vbYesNoCancel + vbDefaultButton2, "VBUnzip - Datei existiert bereits")
    If lRet = vbNo Then Exit Function
    
    If lRet = vbCancel Then
        CBDllRep = 104  ' 104 - overwrite none
        Exit Function
    End If
    
    CBDllRep = 102      ' 102 - overwrite, 103 - overwrite all
End Function

Private Sub CBDllMessage(ByVal lUnPackSize As Long, _
        ByVal lPackSize As Long, _
        ByVal nCompFactor As Integer, _
        ByVal nMonth As Integer, _
        ByVal nDay As Integer, _
        ByVal nYear As Integer, _
        ByVal nHour As Integer, _
        ByVal nMinute As Integer, _
        ByVal c As Byte, _
        ByRef tFName As CBCH, _
        ByRef tMethod As CBCH, _
        ByVal lCRC As Long, _
        ByVal fcrypt As Byte)
    On Error Resume Next
    
    Dim sBuff As String * 128
    Dim sFile As String
    Dim sMethod As String
    Dim X As Long
    
    sBuff = Space$(128)
    If lNumFilesInArchive = 0 Then
        Mid$(sBuff, 1, 50) = "Filename:"
        Mid$(sBuff, 53, 4) = "Size"
        Mid$(sBuff, 62, 4) = "Date"
        Mid$(sBuff, 71, 4) = "Time"
        sZipMsg = sBuff & vbCrLf
        sBuff = Space$(128)
    End If
    
    For X = 0 To 255
        If tFName.ch(X) = 0 Then Exit For
        sFile = sFile & Chr$(tFName.ch(X))
    Next X
    
    Mid$(sBuff, 1, 50) = Mid$(sFile, 1, 50)
    Mid$(sBuff, 51, 7) = Right$(Space$(7) & CStr(lPackSize), 7)
    Mid$(sBuff, 60, 3) = Right$(CStr(nDay), 2) & "."
    Mid$(sBuff, 63, 3) = Right$("0" & CStr(nMonth), 2) & "."
    Mid$(sBuff, 66, 2) = Right$("0" & CStr(nYear), 2)
    Mid$(sBuff, 70, 3) = Right$(CStr(nHour), 2) & ":"
    Mid$(sBuff, 73, 2) = Right$("0" & CStr(nMinute), 2)
    Mid$(sBuff, 76, 2) = Right$(" " & CStr(nCompFactor), 2)
    Mid$(sBuff, 79, 8) = Right$(Space$(8) & CStr(lUnPackSize), 8)
    Mid$(sBuff, 88, 8) = Right$(Space$(8) & CStr(lCRC), 8)
    Mid$(sBuff, 97, 2) = Hex$(c)
    Mid$(sBuff, 100, 2) = Hex$(fcrypt)
    
    For X = 0 To 255
        If tMethod.ch(X) = 0 Then Exit For
        sMethod = sMethod & Chr$(tMethod.ch(X))
    Next X
    
    sZipMsg = sZipMsg & sBuff & vbCrLf
    sZipMsg = sZipMsg & sMethod & vbCrLf
    lNumFilesInArchive = lNumFilesInArchive + 1
End Sub

Private Sub CBDllCountFiles(ByVal lUnPackSize As Long, _
        ByVal lPackSize As Long, _
        ByVal nCompFactor As Integer, _
        ByVal nMonth As Integer, _
        ByVal nDay As Integer, _
        ByVal nYear As Integer, _
        ByVal nHour As Integer, _
        ByVal nMinute As Integer, _
        ByVal c As Byte, _
        ByRef tFName As CBCH, _
        ByRef tMethod As CBCH, _
        ByVal lCRC As Long, _
        ByVal fcrypt As Byte)
    On Error Resume Next
    
    Dim sFile As String
    Dim X As Long
    
    For X = 0 To 255
        If tFName.ch(X) = 0 Then Exit For
        sFile = sFile & Chr$(tFName.ch(X))
    Next X
    
    If Right$(sFile, 1) <> "/" And lPackSize <> 0 And _
        nCompFactor <> 0 And lUnPackSize <> 0 Then
    dblZIPUnpackedBytes = dblZIPUnpackedBytes + lUnPackSize
    dblZIPPackedBytes = dblZIPPackedBytes + lPackSize
    lNumFilesInArchive = lNumFilesInArchive + 1
End If
End Sub

#################################################################
EntPacker f�r Ace, Rar, Zip
Copyright Emil Weiss
f�r Testzwecke freigestellt
emil.weiss@koeln.netsurf.de
http://koeln.netsurf.de/~emil.weiss (Only IE4 or later)
##################################################################

Option Explicit
Private Type ZIPNAMES
s(0 To 99) As String
End Type
' Callback large string

Private Type CBCHAR
ch(32800) As Byte
End Type
' Callback small string

Private Type CBCH
ch(256) As Byte
End Type
Private Type DCLIST
ExtractOnlyNewer As Long ' true, if you are extract only newer
SpaceToUnderscore As Long ' true, if convert space to underscore
PromptToOverwrite As Long ' true, if prompt to overwrite wanted
fQuiet As Long ' quite flag: 1 - few messages, 2 - no messages
' 0 - all messages

ncflag As Long ' true, if you want to write to stdout
ntflag As Long ' test zip file
nvflag As Long ' verbose listing
nUflag As Long ' "update" (extract only newer/new files)
nzflag As Long ' display zip file comment
ndflag As Long ' all args are files/dir to be extracted
noflag As Long ' true, if you are to always overwrite files, false if not
naflag As Long ' do end-of-line translation
nZIflag As Long ' true, if you want to get zip info
C_flag As Long ' be case insensitive if true
fPrivilege As Long ' 1 - restore Acl's. 2 - use privileges
Zip As String ' zip file name
ExtractDir As String ' directory to extract to. This should be NULL if you are
' extracting to the current directory

End Type
Private Type USERFUNCTION
DllPrnt As Long ' address of application's print routine or NULL
DLLSND As Long ' address of application's sound routine or NULL
DLLREPLACE As Long ' address of application's replace routine or NULL
DLLPASSWORD As Long ' address of application's password routine or NULL
DllMessage As Long ' address of application's routine for displaying
' information about specific files in the archive or NULL.

' Used for listing the contents of an archive

cchComment As Integer ' flag to be set if archive has a comment
TotalSizeComp As Long ' value to be filled in by the dll for the total compressed
' size of the archive. Note this value does not include

' the size of the archive header and central directory list.

TotalSize As Long ' value to be filled in by the dll for the total size of
' all files in the archive.

CompFactor As Long ' value to be filled in by the dll for the overall compression
' factor.

NumMembers As Long ' total number of files in the archive
End Type
Private Type UZPVER
structlen As Long ' length of the struct being passed
flag As Long ' bit 0: is_beta, bit1: uses_zlib
beta As String * 10 '
date As String * 20
zlib As String * 10
unzip(1 To 4) As Byte
zipinfo(1 To 4) As Byte
os2dll As Long
windll(1 To 4) As Byte
End Type
' ifnc - number of files names being passed. If all files are to be extracted

' then this can be zero

' ifnv - file names to be unarchived. Wildcard patterns are recognized and

' expanded. If all files are to be extracted, then this can be NULL

' xfnc - number of "file names to be excluded from processing" being passed.

' If all files are to be extracted, set this argument to NULL

' xfnv - file names to be excluded from the unarchiving process. Wildcard

' characters are allowed and expanded. If all files are to be extracted,

' set this argument to NULL

' lpDCL - pointer to a structure with the flags for setting the various options,

' as well as the zip file name

' lpUserFunc- pointer to a structure that contains pointers to functions in the

' calling application, as well as the sizes passed back to the calling

' application etc.

Private Declare Function windll_unzip Lib "unzip32.dll" _
(ByVal ifnc As Long, _
ByRef ifnv As ZIPNAMES, _
ByVal xfnc As Long, _
ByRef xfnv As ZIPNAMES, _
lpDCL As DCLIST, _
lpUserFunc As USERFUNCTION) As Long
Private Declare Sub UzpVersion2 Lib "unzip32.dll" (uzpv As UZPVER)
Private sZipMsg As String
Private lNumFilesInArchive As Long
Private sZipInfo As String
Private dblZIPUnpackedBytes As Double
Private dblZIPPackedBytes As Double
Public Function UnpackZIP(sFilename As String, _
Optional ocolFiles As Collection = Nothing, _
Optional ocolXFiles As Collection = Nothing) As Boolean
Dim lMilliSeconds As Long
Dim lNumFiles As Long
Dim dblUnpackedBytes As Double ' k�nnte sehr viel werden, deshalb kein Long
Dim dblPackedBytes As Double ' k�nnte sehr viel werden, deshalb kein Long
Dim dblExtractedBytes As Double
Dim bMultVolume As Boolean

' Anzahl der Dateien bestimmen und

' Gr��e aller Dateien ermitteln:

frmPGress2.lblExtractPath.Caption = "Teste Archiv(e)"
frmPGress2.lblExtractPath.Refresh

If Not InspectZIPArchiveDLL(sFilename, lMilliSeconds, _
lNumFiles, dblUnpackedBytes, dblPackedBytes, _
frmPGress2.lblArchive) Then Exit Function

frmPGress2.ccrpPGBar.Max = lNumFiles
UnpackZIP = VBUnzip(sFilename, gsExtractPfad, 0, 0, 0, 1, ocolFiles, ocolXFiles)
End Function

Private Function VBUnzip(sFile As String, _
sExtdir As String, _
nPrompOverWr As Integer, _
nAlwaysOverWr As Integer, _
nVerboseList As Integer, _
nArgsAreDirs As Integer, _
colFiles As Collection, _
colXFiles As Collection) As Boolean
Dim MYDCL As DCLIST
Dim MYUSER As USERFUNCTION
Dim MYVER As UZPVER
Dim lNumFiles As Long
Dim vbzipnam As ZIPNAMES
Dim lNumXFiles As Long
Dim vbxnames As ZIPNAMES
Dim X As Long

sZipInfo = ""
lNumFilesInArchive = 0
sZipMsg = ""
vbzipnam.s(0) = vbNullString
vbxnames.s(0) = vbNullString

If Not colFiles Is Nothing Then
lNumFiles = colFiles.Count
For X = 1 To colFiles.Count
vbzipnam.s(X) = colFiles.Item(X)
Next X
End If

If Not colXFiles Is Nothing Then
lNumXFiles = colXFiles.Count
For X = 1 To colXFiles.Count
vbxnames.s(X) = colXFiles.Item(X)
Next X
End If

With MYDCL
.ExtractOnlyNewer = 0
.SpaceToUnderscore = 0
.PromptToOverwrite = nPrompOverWr
.fQuiet = 0
.ncflag = 0
.ntflag = 0
.nvflag = nVerboseList
.nUflag = 0
.nzflag = 0
.ndflag = nArgsAreDirs
.noflag = nAlwaysOverWr
.naflag = 0
.nZIflag = 0
.C_flag = 0
.fPrivilege = 0
.Zip = sFile
.ExtractDir = sExtdir
End With

With MYUSER
.DllPrnt = FnPtr(AddressOf CBDllPrnt)
.DLLSND = 0&
.DLLREPLACE = FnPtr(AddressOf CBDllRep)
If nVerboseList = 1 Then
.DllMessage = FnPtr(AddressOf CBDllCountFiles)
End If
End With

With MYVER
.structlen = Len(MYVER)
.beta = Space$(9) & vbNullChar
.date = Space$(19) & vbNullChar
.zlib = Space$(9) & vbNullChar
End With

UzpVersion2 MYVER
glRet = windll_unzip(lNumFiles, vbzipnam, lNumXFiles, vbxnames, MYDCL, MYUSER)

If glRet <> 0 Then
MsgBox glRet
VBUnzip = False
Else
VBUnzip = True
End If
End Function

Public Function InspectZIPArchiveDLL(sFile As String, _
ByRef lMilliSeconds As Long, _
ByRef lNumFiles As Long, _
ByRef dblUnpackedBytes As Double, _
ByRef dblPackedBytes As Double, _
lblArchiv As Label) As Boolean
On Error GoTo ErrExit

Dim sFilename As String

StartTimer

sFilename = sFile

If VBUnzip(sFilename, gsExtractPfad, 0, 0, 1, 1, Nothing, Nothing) Then
InspectZIPArchiveDLL = True
lMilliSeconds = MeasureTime
lNumFiles = lNumFilesInArchive
dblUnpackedBytes = dblZIPUnpackedBytes
dblPackedBytes = dblZIPPackedBytes
End If

Exit Function

ErrExit:
ShowError

Exit Function
End Function

Public Function FnPtr(ByVal lp As Long) As Long
FnPtr = lp
End Function

Private Function CBDllPrnt(ByRef tInfo As CBCHAR, ByVal lChars As Long) As Long
On Error Resume Next

Dim sInfo As String
Dim X As Long
Dim nCPos As Long

For X = 0 To lChars
If tInfo.ch(X) = 0 Then Exit For
sInfo = sInfo & Chr$(tInfo.ch(X))
Next X
sZipInfo = sZipInfo & sInfo

If Asc(sInfo) <> 10 Then
nCPos = InStr(1, sInfo, vbLf)
If nCPos > 0 Then
sInfo = Mid$(sInfo, nCPos + 1)
End If
frmPGress2.lblExtractPath.Caption = sInfo
If frmPGress2.ccrpPGBar.Value < frmPGress2.ccrpPGBar.Max Then
frmPGress2.ccrpPGBar.Value = frmPGress2.ccrpPGBar.Value + 1
End If

DoEvents
End If
CBDllPrnt = 0
End Function

Private Function CBDllRep(ByRef tFName As CBCHAR) As Long
On Error Resume Next

Dim sFile As String
Dim X As Long
Dim lRet As Long

CBDllRep = 100 ' 100 - do not overwrite - keep asking user

For X = 0 To 255
If tFName.ch(X) = 0 Then Exit For
sFile = sFile & Chr$(tFName.ch(X))
Next X

lRet = MsgBox("Soll die Datei """ & sFile & """ �berschrieben werden?", _
vbYesNoCancel + vbDefaultButton2, "VBUnzip - Datei existiert bereits")
If lRet = vbNo Then Exit Function

If lRet = vbCancel Then
CBDllRep = 104 ' 104 - overwrite none
Exit Function
End If

CBDllRep = 102 ' 102 - overwrite, 103 - overwrite all
End Function

Private Sub CBDllMessage(ByVal lUnPackSize As Long, _
ByVal lPackSize As Long, _
ByVal nCompFactor As Integer, _
ByVal nMonth As Integer, _
ByVal nDay As Integer, _
ByVal nYear As Integer, _
ByVal nHour As Integer, _
ByVal nMinute As Integer, _
ByVal c As Byte, _
ByRef tFName As CBCH, _
ByRef tMethod As CBCH, _
ByVal lCRC As Long, _
ByVal fcrypt As Byte)
On Error Resume Next

Dim sBuff As String * 128
Dim sFile As String
Dim sMethod As String
Dim X As Long

sBuff = Space$(128)
If lNumFilesInArchive = 0 Then
Mid$(sBuff, 1, 50) = "Filename:"
Mid$(sBuff, 53, 4) = "Size"
Mid$(sBuff, 62, 4) = "Date"
Mid$(sBuff, 71, 4) = "Time"
sZipMsg = sBuff & vbCrLf
sBuff = Space$(128)
End If

For X = 0 To 255
If tFName.ch(X) = 0 Then Exit For
sFile = sFile & Chr$(tFName.ch(X))
Next X

Mid$(sBuff, 1, 50) = Mid$(sFile, 1, 50)
Mid$(sBuff, 51, 7) = Right$(Space$(7) & CStr(lPackSize), 7)
Mid$(sBuff, 60, 3) = Right$(CStr(nDay), 2) & "."
Mid$(sBuff, e', 3) = Right$("0" & CStr(nMonth), 2) & "."
Mid$(sBuff, 66, 2) = Right$("0" & CStr(nYear), 2)
Mid$(sBuff, 70, 3) = Right$(CStr(nHour), 2) & ":"
Mid$(sBuff, 73, 2) = Right$("0" & CStr(nMinute), 2)
Mid$(sBuff, 76, 2) = Right$(" " & CStr(nCompFactor), 2)
Mid$(sBuff, 79, 8) = Right$(Space$(8) & CStr(lUnPackSize), 8)
Mid$(sBuff, 88, 8) = Right$(Space$(8) & CStr(lCRC), 8)
Mid$(sBuff, 97, 2) = Hex$(c)
Mid$(sBuff, 100, 2) = Hex$(fcrypt)

For X = 0 To 255
If tMethod.ch(X) = 0 Then Exit For
sMethod = sMethod & Chr$(tMethod.ch(X))
Next X

sZipMsg = sZipMsg & sBuff & vbCrLf
sZipMsg = sZipMsg & sMethod & vbCrLf
lNumFilesInArchive = lNumFilesInArchive + 1
End Sub

Private Sub CBDllCountFiles(ByVal lUnPackSize As Long, _
ByVal lPackSize As Long, _
ByVal nCompFactor As Integer, _
ByVal nMonth As Integer, _
ByVal nDay As Integer, _
ByVal nYear As Integer, _
ByVal nHour As Integer, _
ByVal nMinute As Integer, _
ByVal c As Byte, _
ByRef tFName As CBCH, _
ByRef tMethod As CBCH, _
ByVal lCRC As Long, _
ByVal fcrypt As Byte)
On Error Resume Next

Dim sFile As String
Dim X As Long

For X = 0 To 255
If tFName.ch(X) = 0 Then Exit For
sFile = sFile & Chr$(tFName.ch(X))
Next X

If Right$(sFile, 1) <> "/" And lPackSize <> 0 And _
nCompFactor <> 0 And lUnPackSize <> 0 Then
dblZIPUnpackedBytes = dblZIPUnpackedBytes + lUnPackSize
dblZIPPackedBytes = dblZIPPackedBytes + lPackSize
lNumFilesInArchive = lNumFilesInArchive + 1
End If
End Sub

#################################################################
EntPacker f�r Ace, Rar, Zip
Copyright Emil Weiss
f�r Testzwecke freigestellt
emil.weiss@koeln.netsurf.de
http://koeln.netsurf.de/~emil.weiss (Only IE4 or later)
##################################################################