mod1.bas

一个可以生成ZIP的解压缩和被解压缩的DLL,这是本人在2001年刚学完VB后写的,我认为对初学者编好DLL很有意义

    MYOPT.fMove = iMove                                 ' 1 if deleting files added or updated
    MYOPT.fDeleteEntries = DeleteEntries                ' 1 if files passed have to be deleted
    MYOPT.fUpdate = updat                               ' 1 if updating zip file--overwrite only if newer
    MYOPT.fFreshen = freshen                            ' 1 if freshening zip file--overwrite only
    MYOPT.fJunkSFX = 0                                  ' 1 if junking sfx prefix
    MYOPT.fLatestTime = 0                               ' 1 if setting zip file time to time of latest file in archive
    MYOPT.fComment = 0                                  ' 1 if putting comment in zip file
    MYOPT.fOffsets = 0                                  ' 1 if updating archive offsets for sfx Files
    MYOPT.fPrivilege = 0                                ' 1 if not saving privelages
    MYOPT.fEncryption = 0                               ' Read only property!
    MYOPT.fRepair = 0                                   ' 1=> fix archive, 2=> try harder to fix
    MYOPT.flevel = 0                                    ' compression level - should be 0!!!
    MYOPT.date = vbNullString                           ' "12/31/79"? US Date?
    MYOPT.szRootDir = UCase$(basename)
    
    retcode = ZpInit(MYUSER)
    ' Set options
    retcode = ZpSetOptions(MYOPT)
    
    ' ZCL not needed in VB
    ' MYZCL.argc = 2
    ' MYZCL.filename = "c:\wiz\new.zip"
    ' MYZCL.fileArray = MYNAMES
    
    ' Go for it!
    
    retcode = ZpArchive(argc, zipname, mynames)
    
    VBZip = retcode
End Function
Public Sub UZReceiveDLLMessage(ByVal ucsize As Long, _
    ByVal csiz As Long, _
    ByVal cfactor As Integer, _
    ByVal mo As Integer, _
    ByVal dy As Integer, _
    ByVal yr As Integer, _
    ByVal hh As Integer, _
    ByVal mm As Integer, _
    ByVal c As Byte, ByRef fname As UNZIPCBCh, _
    ByRef meth As UNZIPCBCh, ByVal crc As Long, _
    ByVal fCrypt As Byte)
    
    Dim xx                              As Long
    Dim s0                              As String
    Dim strout                          As String * 80
    
   
    On Error Resume Next
    strout = Space(80)
    
    '-- For Zip Message Printing
    If uZipNumber = 0 Then
      Mid(strout, 1, 50) = "Filename:"
      Mid(strout, 53, 4) = "Size"
      Mid(strout, 62, 4) = "Date"
      Mid(strout, 71, 4) = "Time"
      uZipMessage = strout & vbNewLine
      strout = Space(80)
    End If
    
    s0 = ""
    
    
    For xx = 0 To 255
      If fname.ch(xx) = 0 Then Exit For
      s0 = s0 & Chr(fname.ch(xx))
    Next
    
    '-- Assign Zip Information For Printing
    Mid(strout, 1, 50) = Mid(s0, 1, 50)
    Mid(strout, 51, 7) = Right("        " & Str(ucsize), 7)
    Mid(strout, 60, 3) = Right("0" & Trim(Str(mo)), 2) & "/"
    Mid(strout, 63, 3) = Right("0" & Trim(Str(dy)), 2) & "/"
    Mid(strout, 66, 2) = Right("0" & Trim(Str(yr)), 2)
    Mid(strout, 70, 3) = Right(Str(hh), 2) & ":"
    Mid(strout, 73, 2) = Right("0" & Trim(Str(mm)), 2)
    
    ' Mid(strout, 75, 2) = Right(" " & Str(cfactor), 2)
    ' Mid(strout, 78, 8) = Right("        " & Str(csiz), 8)
    ' s0 = ""
    ' For xx = 0 To 255
    '     If meth.ch(xx) = 0 Then exit for
    '     s0 = s0 & Chr(meth.ch(xx))
    ' Next xx
    
    '-- Do Not Modify Below!!!
    uZipMessage = uZipMessage & strout & vbNewLine
    uZipNumber = uZipNumber + 1

End Sub


Public Function UZDLLPrnt(ByRef fname As UNZIPCBChar, ByVal x As Long) As Long

    Dim xx                              As Long
    Dim s0                              As String
    
    
    '-- Always Put This In Callback Routines!
    On Error Resume Next
    
    s0 = ""
    
    
    For xx = 0 To x - 1
      If fname.ch(xx) = 0 Then Exit For
      s0 = s0 & Chr(fname.ch(xx))
    Next
    
    '-- Assign Zip Information
    If Mid$(s0, 1, 1) = vbLf Then s0 = vbNewLine ' Damn UNIX :-)
    uZipInfo = uZipInfo & s0
    
    msOutput = uZipInfo
      
    UZDLLPrnt = 0

End Function


Public Function UZDLLServ(ByRef mname As UNZIPCBChar, ByVal x As Long) As Long

    Dim xx                              As Long
    Dim s0                              As String
    
    
    '-- Always Put This In Callback Routines!
    On Error Resume Next
    
    s0 = ""
    '-- Get Zip32.DLL Message For processing
    For xx = 0 To x - 1
        If mname.ch(xx) = 0 Then Exit For
        s0 = s0 + Chr(mname.ch(xx))
    Next
    ' At this point, s0 contains the message passed from the DLL
    ' It is up to the developer to code something useful here :)
    UZDLLServ = 0 ' Setting this to 1 will abort the zip!

End Function


Public Function UZDLLPass( _
    ByRef p As UNZIPCBCh, _
    ByVal n As Long, _
    ByRef m As UNZIPCBCh, _
    ByRef Name As UNZIPCBCh) As Integer

    Dim xx                              As Integer
    Dim prompt                          As String
    
    Dim szpassword                      As String
    
    '-- Always Put This In Callback Routines!
    On Error Resume Next
    
    UZDLLPass = 1
    
    If uVBSkip = 1 Then Exit Function
    
    '-- Get The Zip File Password
    szpassword = InputBox("Please Enter The Password!")
    
    '-- No Password So Exit The Function
    If szpassword = "" Then
      uVBSkip = 1
      Exit Function
    End If
    
    '-- Zip File Password So Process It
    For xx = 0 To 255
      If m.ch(xx) = 0 Then
        Exit For
      Else
        prompt = prompt & Chr(m.ch(xx))
      End If
    Next
    
    For xx = 0 To n - 1
      p.ch(xx) = 0
    Next
    
    For xx = 0 To Len(szpassword) - 1
      p.ch(xx) = Asc(Mid(szpassword, xx + 1, 1))
    Next
    
    p.ch(xx) = Chr(0) ' Put Null Terminator For C
    
    UZDLLPass = 0

End Function


Public Function UZDLLRep(ByRef fname As UNZIPCBChar) As Long

    Dim xx                              As Long
    Dim s0                              As String
    
    '-- Always Put This In Callback Routines!
    On Error Resume Next
    
    UZDLLRep = 100 ' 100 = Do Not Overwrite - Keep Asking User
    s0 = ""
    
    For xx = 0 To 255
      If fname.ch(xx) = 0 Then xx = 99999 Else s0 = s0 & Chr(fname.ch(xx))
    Next
    
    '-- This Is The MsgBox Code
    xx = MsgBox("Overwrite " & s0 & "?", vbExclamation & vbYesNoCancel, _
                "VBUnZip32 - File Already Exists!")
    
    If xx = vbNo Then Exit Function
    
    If xx = vbCancel Then
      UZDLLRep = 104       ' 104 = Overwrite None
      Exit Function
    End If
    
    UZDLLRep = 102         ' 102 = Overwrite 103 = Overwrite All

End Function

'=========================================================================================
' ヘ