mod1.bas

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

Attribute VB_Name = "Module1"
Option Explicit
Public Type UNZIPnames
    uzFiles(0 To 99)                    As String
End Type
Public Type UNZIPCBChar
    ch(32800)                           As Byte
End Type
Public Type UNZIPCBCh
    ch(256)                             As Byte
End Type
Public Type DCLIST
    ExtractOnlyNewer                    As Long         ' 1 = Extract Only Newer, Else 0
    SpaceToUnderscore                   As Long         ' 1 = Convert Space To Underscore, Else 0
    PromptToOverwrite                   As Long         ' 1 = Prompt To Overwrite Required, Else 0
    fQuiet                              As Long         ' 2 = No Messages, 1 = Less, 0 = All
    ncflag                              As Long         ' 1 = Write To Stdout, Else 0
    ntflag                              As Long         ' 1 = Test Zip File, Else 0
    nvflag                              As Long         ' 0 = Extract, 1 = List Zip Contents
    nUflag                              As Long         ' 1 = Extract Only Newer, Else 0
    nzflag                              As Long         ' 1 = Display Zip File Comment, Else 0
    ndflag                              As Long         ' 1 = Honor Directories, Else 0
    noflag                              As Long         ' 1 = Overwrite Files, Else 0
    naflag                              As Long         ' 1 = Convert CR To CRLF, Else 0
    nZIflag                             As Long         ' 1 = Zip Info Verbose, Else 0
    C_flag                              As Long         ' 1 = Case Insensitivity, 0 = Case Sensitivity
    fPrivilege                          As Long         ' 1 = ACL, 2 = Privileges
    zip                                 As String       ' The Zip Filename To Extract Files
    ExtractDir                          As String       ' The Extraction Directory, NULL If Extracting To Current Dir
End Type
Public Type ZIPnames
    s(0 To 99)                          As String
End Type
Public Type USERFUNCTION
    UZDLLPrnt                           As Long         ' Pointer To Apps Print Function
    UZDLLSND                            As Long         ' Pointer To Apps Sound Function
    UZDLLREPLACE                        As Long         ' Pointer To Apps Replace Function
    UZDLLPASSWORD                       As Long         ' Pointer To Apps Password Function
    UZDLLMESSAGE                        As Long         ' Pointer To Apps Message Function
    UZDLLSERVICE                        As Long         ' Pointer To Apps Service Function (Not Coded!)
    TotalSizeComp                       As Long         ' Total Size Of Zip Archive
    TotalSize                           As Long         ' Total Size Of All Files In Archive
    CompFactor                          As Long         ' Compression Factor
    NumMembers                          As Long         ' Total Number Of All Files In The Archive
    cchComment                          As Integer      ' Flag If Archive Has A Comment!
End Type


Public msOutput                         As String
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Declare Function ZpInit Lib "zip32.dll" (ByRef Zipfun As ZIPUSERFUNCTIONS) As Long
Private Declare Function ZpSetOptions Lib "zip32.dll" (ByRef Opts As ZPOPT) As Long
Private Declare Function ZpGetOptions Lib "zip32.dll" () As ZPOPT
Private Declare Function ZpArchive Lib "zip32.dll" (ByVal argc As Long, ByVal funame As String, ByRef argv As ZIPnames) As Long

Private Type ZPOPT
    fSuffix                             As Long
    fEncrypt                            As Long
    fSystem                             As Long
    fVolume                             As Long
    fExtra                              As Long
    fNoDirEntries                       As Long
    fExcludeDate                        As Long
    fIncludeDate                        As Long
    fVerbose                            As Long
    fQuiet                              As Long
    fCRLF_LF                            As Long
    fLF_CRLF                            As Long
    fJunkDir                            As Long
    fRecurse                            As Long
    fGrow                               As Long
    fForce                              As Long
    fMove                               As Long
    fDeleteEntries                      As Long
    fUpdate                             As Long
    fFreshen                            As Long
    fJunkSFX                            As Long
    fLatestTime                         As Long
    fComment                            As Long
    fOffsets                            As Long
    fPrivilege                          As Long
    fEncryption                         As Long
    fRepair                             As Long
    flevel                              As Byte
    date                                As String       ' 8 bytes long
    szRootDir                           As String       ' up to 256 bytes long
End Type

Private Type ZIPUSERFUNCTIONS
    DllPrnt                             As Long
    DLLPASSWORD                         As Long
    DLLCOMMENT                          As Long
    DLLSERVICE                          As Long
End Type



Private Type CBChar
    ch(4096)                            As Byte
End Type


Private uZipNumber                      As Integer
Private uZipMessage                     As String
Private uZipInfo                        As String
Private uVBSkip                         As Integer



Function FnPtr(ByVal lp As Long) As Long

    FnPtr = lp

End Function


Function DllPrnt(ByRef fname As CBChar, ByVal x As Long) As Long
    
    Dim xx                              As Long
    Dim s0                              As String
    Dim sVbZipInf                       As String
    
    ' always put this in callback routines!
    On Error Resume Next
    s0 = ""
    For xx = 0 To x
        If fname.ch(xx) = 0 Then xx = 99999 Else s0 = s0 + Chr(fname.ch(xx))
    Next xx
    
    Debug.Print sVbZipInf & s0
    msOutput = msOutput & s0
    
    sVbZipInf = ""
    
    DoEvents
    DllPrnt = 0
    
End Function
Function DllServ(ByRef fname As CBChar, ByVal x As Long) As Long
    
    Dim xx                              As Long
    Dim s0                              As String
    
    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
    
    DllServ = 0
    
End Function
Function DllPass(ByRef s1 As Byte, x As Long, _
    ByRef s2 As Byte, _
    ByRef s3 As Byte) As Long
   On Error Resume Next
   
    DllPass = 1
    
End Function
Function DllComm(ByRef s1 As CBChar) As CBChar
    
    ' always put this in callback routines!
    On Error Resume Next
    ' not supported always return \0
    s1.ch(0) = vbNullString
    DllComm = s1
    
End Function


Public Function VBZip(argc As Integer, zipname As String, _
    mynames As ZIPnames, junk As Integer, _
    recurse As Integer, updat As Integer, _
    freshen As Integer, basename As String, _
    Optional Encrypt As Integer = 0, _
    Optional IncludeSystem As Integer = 0, _
    Optional IgnoreDirectoryEntries As Integer = 0, _
    Optional Verbose As Integer = 0, _
    Optional Quiet As Integer = 0, _
    Optional CRLFtoLF As Integer = 0, _
    Optional LFtoCRLF As Integer = 0, _
    Optional Grow As Integer = 0, _
    Optional Force As Integer = 0, _
    Optional iMove As Integer = 0, _
    Optional DeleteEntries As Integer = 0) As Long
    
    Dim xx                              As Integer
    Dim hmem                            As Long
    Dim retcode                         As Long
    Dim MYUSER                          As ZIPUSERFUNCTIONS
    Dim MYOPT                           As ZPOPT
    
    On Error Resume Next ' nothing will go wrong :-)
    
    msOutput = ""
    
    ' Set address of callback functions
    MYUSER.DllPrnt = FnPtr(AddressOf DllPrnt)
    MYUSER.DLLPASSWORD = FnPtr(AddressOf DllPass)
    MYUSER.DLLCOMMENT = FnPtr(AddressOf DllComm)
    MYUSER.DLLSERVICE = 0& ' not coded yet :-)
'    retcode = ZpInit(MYUSER)
    
    ' Set zip options
    MYOPT.fSuffix = 0                                   ' include suffixes (not yet implemented)
    MYOPT.fEncrypt = Encrypt                            ' 1 if encryption wanted
    MYOPT.fSystem = IncludeSystem                       ' 1 to include system/hidden files
    MYOPT.fVolume = 0                                   ' 1 if storing volume label
    MYOPT.fExtra = 0                                    ' 1 if including extra attributes
    MYOPT.fNoDirEntries = IgnoreDirectoryEntries        ' 1 if ignoring directory entries
    MYOPT.fExcludeDate = 0                              ' 1 if excluding files earlier than a specified date
    MYOPT.fIncludeDate = 0                              ' 1 if including files earlier than a specified date
    MYOPT.fVerbose = Verbose                            ' 1 if full messages wanted
    MYOPT.fQuiet = Quiet                                ' 1 if minimum messages wanted
    MYOPT.fCRLF_LF = CRLFtoLF                           ' 1 if translate CR/LF to LF
    MYOPT.fLF_CRLF = LFtoCRLF                           ' 1 if translate LF to CR/LF
    MYOPT.fJunkDir = junk                               ' 1 if junking directory names
    MYOPT.fRecurse = recurse                            ' 1 if recursing into subdirectories
    MYOPT.fGrow = Grow                                  ' 1 if allow appending to zip file
    MYOPT.fForce = Force                                ' 1 if making entries using DOS names