module2.bas

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

Attribute VB_Name = "Module2"
Option Explicit
Dim s0$, xx As Long
    
Public strout As String * 80


' argv
Private Type ZIPnames
    s(0 To 99) As String
End Type

' Callback large "string" (sic)
Private Type CBChar
    ch(32800) As Byte
End Type

' Callback small "string" (sic)
Private Type CBCh
    ch(256) As Byte
End Type

' DCL structure
Private Type DCLIST
    ExtractOnlyNewer As Long
    SpaceToUnderscore As Long
    PromptToOverwrite As Long
    fQuiet As Long
    ncflag As Long
    ntflag As Long
    nvflag As Long
    nUflag As Long
    nzflag As Long
    ndflag As Long
    noflag As Long
    naflag As Long
    nZIflag As Long
    C_flag As Long
    fPrivilege As Long
    Zip As String
    ExtractDir As String
End Type

' Userfunctions structure
Private Type USERFUNCTION
    DllPrnt As Long
    DLLSND As Long
    DLLREPLACE As Long
    DLLPASSWORD As Long
    DLLMESSAGE As Long
    DLLSERVICE As Long
    TotalSizeComp As Long
    TotalSize As Long
    CompFactor As Long
    NumMembers As Long
    cchComment As Integer
End Type

' Unzip32.dll version structure
Private Type UZPVER
    structlen As Long
    flag As Long
    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


Private Declare Function windll_unzip Lib "unzip32.dll" (ByVal ifnc As Long, ByRef ifnv As ZIPnames, ByVal xfnc As Long, ByRef xfnv As ZIPnames, dcll As DCLIST, Userf As USERFUNCTION) As Long

Private Declare Sub UzpVersion2 Lib "unzip32.dll" (uzpv As UZPVER)


Dim MYDCL As DCLIST
Dim MYUSER As USERFUNCTION
Dim MYVER As UZPVER

Global vbzipnum As Long, vbzipmes As String
Global vbzipinf As String
Global vbzipnam As ZIPnames, vbxnames As ZIPnames
Global crlf$
Function FnPtr(ByVal lp As Long) As Long
    FnPtr = lp
End Function

' Callback for unzip32.dll
Function ReceiveDllMessage(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 CBCh, _
    ByRef meth As CBCh, ByVal crc As Long, _
    ByVal fCrypt As Byte) As String
    
    

    

    ' always put this in callback routines!
    On Error Resume Next
     strout = Space(80)
    If vbzipnum = 0 Then
        Mid$(strout, 1, 50) = "Filename:"
        
        vbzipmes = strout + crlf
        strout = Space(80)
    End If
    s0 = ""
    For xx = 0 To 255
        If fname.ch(xx) = 0 Then xx = 99999 Else s0 = s0 & Chr$(fname.ch(xx))
    
    
    Next xx
    Mid$(strout, 1, 50) = Mid$(s0, 1, 50) 's0 为程序的文件名称
    
  vbzipmes = vbzipmes + strout + crlf
  vbzipnum = vbzipnum + 1
     ReceiveDllMessage = s0
     

End Function

Function LGetFileName() As String

LGetFileName = s0



End Function



' Callback for unzip32.dll
Function DllPrnt(ByRef fname As CBChar, ByVal x As Long) As Long
    Dim s0$, xx As Long

    ' 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
    vbzipinf = vbzipinf + s0
    DllPrnt = 0
End Function

' Callback for unzip32.dll
Function DllPass(ByRef s1 As Byte, x As Long, _
    ByRef s2 As Byte, _
    ByRef s3 As Byte) As Long

    ' always put this in callback routines!
    On Error Resume Next
    ' not supported - always return 1
    DllPass = 1
End Function

' Callback for unzip32.dll
Function DllRep(ByRef fname As CBChar) As Long
    Dim s0$, xx As Long

    ' always put this in callback routines!
    On Error Resume Next
    DllRep = 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 xx
    xx = MsgBox("Overwrite " + s0 + "?", vbYesNoCancel, "VBUnzip - File already exists")
    If xx = vbNo Then Exit Function
    If xx = vbCancel Then
        DllRep = 104 ' 104=overwrite none
        Exit Function
    End If
    DllRep = 102 ' 102=overwrite 103=overwrite all
End Function


' Main subroutine
Sub vbUnzip(fname As String, extdir As String, _
    prom As Integer, ovr As Integer, _
    mess As Integer, dirs As Integer, numfiles As Long, numxfiles As Long)
    Dim xx As Long ' , s1 As String * 20, s2 As String * 256

    ' Set options
    MYDCL.ExtractOnlyNewer = 0      ' 1=extract only newer
    MYDCL.SpaceToUnderscore = 0     ' 1=convert space to underscore
    MYDCL.PromptToOverwrite = prom  ' 1=prompt to overwrite required
    MYDCL.fQuiet = 0                ' 2=no messages 1=less 0=all
    MYDCL.ncflag = 0                ' 1=write to stdout
    MYDCL.ntflag = 0                ' 1=test zip
    MYDCL.nvflag = mess             ' 0=extract 1=list contents
    MYDCL.nUflag = 0                ' 1=extract only newer
    MYDCL.nzflag = 0                ' 1=display zip file comment
    MYDCL.ndflag = dirs             ' 1=honour directories
    MYDCL.noflag = ovr              ' 1=overwrite files
    MYDCL.naflag = 0                ' 1=convert CR to CRLF
    MYDCL.nZIflag = 0               ' 1=Zip Info Verbose
    MYDCL.C_flag = 0                ' 1=Case insensitivity, 0=Case Sensitivity
    MYDCL.fPrivilege = 0            ' 1=ACL 2=priv
    MYDCL.Zip = fname               ' ZIP name
    MYDCL.ExtractDir = extdir       ' Extraction directory, NULL if extracting
                                    ' to current directory
    ' Set Callback addresses
    ' Do not change
    MYUSER.DllPrnt = FnPtr(AddressOf DllPrnt)
    MYUSER.DLLSND = 0& ' not supported
    MYUSER.DLLREPLACE = FnPtr(AddressOf DllRep)
    MYUSER.DLLPASSWORD = FnPtr(AddressOf DllPass)
    MYUSER.DLLMESSAGE = FnPtr(AddressOf ReceiveDllMessage)
    MYUSER.DLLSERVICE = 0& ' not coded yet :)
    
    ' Set Version space
    ' Do not change
    With MYVER
        .structlen = Len(MYVER)
        .beta = Space$(9) & vbNullChar
        .date = Space$(19) & vbNullChar
        .zlib = Space$(9) & vbNullChar
    End With
    
    ' Get version
    Call UzpVersion2(MYVER)
  
    xx = windll_unzip(numfiles, vbzipnam, _
        numxfiles, vbxnames, MYDCL, MYUSER)
    If xx <> 0 Then MsgBox xx
   

End Sub