home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 9 Archive / 09-Archive.zip / unzip540.zip / windll / vb / vbunzip.bas next >
BASIC Source File  |  1998-08-28  |  16KB  |  462 lines
  1. Attribute VB_Name = "VBUnzBas"
  2.  
  3. Option Explicit
  4.  
  5. '-- Please Do Not Remove These Comment Lines!
  6. '----------------------------------------------------------------
  7. '-- Sample VB 5 code to drive unzip32.dll
  8. '-- Contributed to the Info-ZIP project by Mike Le Voi
  9. '--
  10. '-- Contact me at: mlevoi@modemss.brisnet.org.au
  11. '--
  12. '-- Visit my home page at: http://modemss.brisnet.org.au/~mlevoi
  13. '--
  14. '-- Use this code at your own risk. Nothing implied or warranted
  15. '-- to work on your machine :-)
  16. '----------------------------------------------------------------
  17. '--
  18. '-- This Source Code Is Freely Available From The Info-ZIP Project
  19. '-- Web Server At:
  20. '-- http://www.cdrom.com/pub/infozip/infozip.html
  21. '--
  22. '-- A Very Special Thanks To Mr. Mike Le Voi
  23. '-- And Mr. Mike White
  24. '-- And The Fine People Of The Info-ZIP Group
  25. '-- For Letting Me Use And Modify Their Orginal
  26. '-- Visual Basic 5.0 Code! Thank You Mike Le Voi.
  27. '-- For Your Hard Work In Helping Me Get This To Work!!!
  28. '---------------------------------------------------------------
  29. '--
  30. '-- Contributed To The Info-ZIP Project By Raymond L. King.
  31. '-- Modified June 21, 1998
  32. '-- By Raymond L. King
  33. '-- Custom Software Designers
  34. '--
  35. '-- Contact Me At: king@ntplx.net
  36. '-- ICQ 434355
  37. '-- Or Visit Our Home Page At: http://www.ntplx.net/~king
  38. '--
  39. '---------------------------------------------------------------
  40. '--
  41. '-- Modified August 17, 1998
  42. '-- by Christian Spieler
  43. '-- (implemented sort of a "real" user interface)
  44. '--
  45. '---------------------------------------------------------------
  46.  
  47. '-- C Style argv
  48. Private Type UNZIPnames
  49.   uzFiles(0 To 99) As String
  50. End Type
  51.  
  52. '-- Callback Large "String"
  53. Private Type UNZIPCBChar
  54.   ch(32800) As Byte
  55. End Type
  56.  
  57. '-- Callback Small "String"
  58. Private Type UNZIPCBCh
  59.   ch(256) As Byte
  60. End Type
  61.  
  62. '-- UNZIP32.DLL DCL Structure
  63. Private Type DCLIST
  64.   ExtractOnlyNewer  As Long    ' 1 = Extract Only Newer, Else 0
  65.   SpaceToUnderscore As Long    ' 1 = Convert Space To Underscore, Else 0
  66.   PromptToOverwrite As Long    ' 1 = Prompt To Overwrite Required, Else 0
  67.   fQuiet            As Long    ' 2 = No Messages, 1 = Less, 0 = All
  68.   ncflag            As Long    ' 1 = Write To Stdout, Else 0
  69.   ntflag            As Long    ' 1 = Test Zip File, Else 0
  70.   nvflag            As Long    ' 0 = Extract, 1 = List Zip Contents
  71.   nUflag            As Long    ' 1 = Extract Only Newer, Else 0
  72.   nzflag            As Long    ' 1 = Display Zip File Comment, Else 0
  73.   ndflag            As Long    ' 1 = Honor Directories, Else 0
  74.   noflag            As Long    ' 1 = Overwrite Files, Else 0
  75.   naflag            As Long    ' 1 = Convert CR To CRLF, Else 0
  76.   nZIflag           As Long    ' 1 = Zip Info Verbose, Else 0
  77.   C_flag            As Long    ' 1 = Case Insensitivity, 0 = Case Sensitivity
  78.   fPrivilege        As Long    ' 1 = ACL, 2 = Privileges
  79.   Zip               As String  ' The Zip Filename To Extract Files
  80.   ExtractDir        As String  ' The Extraction Directory, NULL If Extracting To Current Dir
  81. End Type
  82.  
  83. '-- UNZIP32.DLL Userfunctions Structure
  84. Private Type USERFUNCTION
  85.   UZDLLPrnt     As Long     ' Pointer To Apps Print Function
  86.   UZDLLSND      As Long     ' Pointer To Apps Sound Function
  87.   UZDLLREPLACE  As Long     ' Pointer To Apps Replace Function
  88.   UZDLLPASSWORD As Long     ' Pointer To Apps Password Function
  89.   UZDLLMESSAGE  As Long     ' Pointer To Apps Message Function
  90.   UZDLLSERVICE  As Long     ' Pointer To Apps Service Function (Not Coded!)
  91.   TotalSizeComp As Long     ' Total Size Of Zip Archive
  92.   TotalSize     As Long     ' Total Size Of All Files In Archive
  93.   CompFactor    As Long     ' Compression Factor
  94.   NumMembers    As Long     ' Total Number Of All Files In The Archive
  95.   cchComment    As Integer  ' Flag If Archive Has A Comment!
  96. End Type
  97.  
  98. '-- UNZIP32.DLL Version Structure
  99. Private Type UZPVER
  100.   structlen       As Long         ' Length Of The Structure Being Passed
  101.   flag            As Long         ' Bit 0: is_beta  bit 1: uses_zlib
  102.   beta            As String * 10  ' e.g., "g BETA" or ""
  103.   date            As String * 20  ' e.g., "4 Sep 95" (beta) or "4 September 1995"
  104.   zlib            As String * 10  ' e.g., "1.0.5" or NULL
  105.   unzip(1 To 4)   As Byte         ' Version Type Unzip
  106.   zipinfo(1 To 4) As Byte         ' Version Type Zip Info
  107.   os2dll          As Long         ' Version Type OS2 DLL
  108.   windll(1 To 4)  As Byte         ' Version Type Windows DLL
  109. End Type
  110.  
  111. '-- This Assumes UNZIP32.DLL Is In Your \Windows\System Directory!
  112. Private Declare Function Wiz_SingleEntryUnzip Lib "unzip32.dll" _
  113.   (ByVal ifnc As Long, ByRef ifnv As UNZIPnames, _
  114.    ByVal xfnc As Long, ByRef xfnv As UNZIPnames, _
  115.    dcll As DCLIST, Userf As USERFUNCTION) As Long
  116.  
  117. Private Declare Sub UzpVersion2 Lib "unzip32.dll" (uzpv As UZPVER)
  118.  
  119. '-- Private Variables For Structure Access
  120. Private UZDCL  As DCLIST
  121. Private UZUSER As USERFUNCTION
  122. Private UZVER  As UZPVER
  123.  
  124. '-- Public Variables For Setting The
  125. '-- UNZIP32.DLL DCLIST Structure
  126. '-- These Must Be Set Before The Actual Call To VBUnZip32
  127. Public uExtractNewer     As Integer  ' 1 = Extract Only Newer, Else 0
  128. Public uSpaceUnderScore  As Integer  ' 1 = Convert Space To Underscore, Else 0
  129. Public uPromptOverWrite  As Integer  ' 1 = Prompt To Overwrite Required, Else 0
  130. Public uQuiet            As Integer  ' 2 = No Messages, 1 = Less, 0 = All
  131. Public uWriteStdOut      As Integer  ' 1 = Write To Stdout, Else 0
  132. Public uTestZip          As Integer  ' 1 = Test Zip File, Else 0
  133. Public uExtractList      As Integer  ' 0 = Extract, 1 = List Contents
  134. Public uExtractOnlyNewer As Integer  ' 1 = Extract Only Newer, Else 0
  135. Public uDisplayComment   As Integer  ' 1 = Display Zip File Comment, Else 0
  136. Public uHonorDirectories As Integer  ' 1 = Honor Directories, Else 0
  137. Public uOverWriteFiles   As Integer  ' 1 = Overwrite Files, Else 0
  138. Public uConvertCR_CRLF   As Integer  ' 1 = Convert CR To CRLF, Else 0
  139. Public uVerbose          As Integer  ' 1 = Zip Info Verbose
  140. Public uCaseSensitivity  As Integer  ' 1 = Case Insensitivity, 0 = Case Sensitivity
  141. Public uPrivilege        As Integer  ' 1 = ACL, 2 = Privileges, Else 0
  142. Public uZipFileName      As String   ' The Zip File Name
  143. Public uExtractDir       As String   ' Extraction Directory, Null If Current Directory
  144.  
  145. '-- Public Program Variables
  146. Public uZipNumber    As Long         ' Zip File Number
  147. Public uNumberFiles  As Long         ' Number Of Files
  148. Public uNumberXFiles As Long         ' Number Of Extracted Files
  149. Public uZipMessage   As String       ' For Zip Message
  150. Public uZipInfo      As String       ' For Zip Information
  151. Public uZipNames     As UNZIPnames   ' Names Of Files To Unzip
  152. Public uExcludeNames As UNZIPnames   ' Names Of Zip Files To Exclude
  153. Public uVbSkip       As Integer      ' For DLL Password Function
  154.  
  155. '-- Puts A Function Pointer In A Structure
  156. '-- For Callbacks.
  157. Public Function FnPtr(ByVal lp As Long) As Long
  158.  
  159.   FnPtr = lp
  160.  
  161. End Function
  162.  
  163. '-- Callback For UNZIP32.DLL - Receive Message Function
  164. Public Sub UZReceiveDLLMessage(ByVal ucsize As Long, _
  165.     ByVal csiz As Long, _
  166.     ByVal cfactor As Integer, _
  167.     ByVal mo As Integer, _
  168.     ByVal dy As Integer, _
  169.     ByVal yr As Integer, _
  170.     ByVal hh As Integer, _
  171.     ByVal mm As Integer, _
  172.     ByVal c As Byte, ByRef fname As UNZIPCBCh, _
  173.     ByRef meth As UNZIPCBCh, ByVal crc As Long, _
  174.     ByVal fCrypt As Byte)
  175.  
  176.   Dim s0     As String
  177.   Dim xx     As Long
  178.   Dim strout As String * 80
  179.  
  180.   '-- Always Put This In Callback Routines!
  181.   On Error Resume Next
  182.  
  183.   '------------------------------------------------
  184.   '-- This Is Where The Received Messages Are
  185.   '-- Printed Out And Displayed.
  186.   '-- You Can Modify Below!
  187.   '------------------------------------------------
  188.  
  189.   strout = Space(80)
  190.  
  191.   '-- For Zip Message Printing
  192.   If uZipNumber = 0 Then
  193.     Mid(strout, 1, 50) = "Filename:"
  194.     Mid(strout, 53, 4) = "Size"
  195.     Mid(strout, 62, 4) = "Date"
  196.     Mid(strout, 71, 4) = "Time"
  197.     uZipMessage = strout & vbNewLine
  198.     strout = Space(80)
  199.   End If
  200.  
  201.   s0 = ""
  202.  
  203.   '-- Do Not Change This For Next!!!
  204.   For xx = 0 To 255
  205.     If fname.ch(xx) = 0 Then Exit For
  206.     s0 = s0 & Chr(fname.ch(xx))
  207.   Next
  208.  
  209.   '-- Assign Zip Information For Printing
  210.   Mid(strout, 1, 50) = Mid(s0, 1, 50)
  211.   Mid(strout, 51, 7) = Right("        " & Str(ucsize), 7)
  212.   Mid(strout, 60, 3) = Right("0" & Trim(Str(mo)), 2) & "/"
  213.   Mid(strout, 63, 3) = Right("0" & Trim(Str(dy)), 2) & "/"
  214.   Mid(strout, 66, 2) = Right("0" & Trim(Str(yr)), 2)
  215.   Mid(strout, 70, 3) = Right(Str(hh), 2) & ":"
  216.   Mid(strout, 73, 2) = Right("0" & Trim(Str(mm)), 2)
  217.  
  218.   ' Mid(strout, 75, 2) = Right(" " & Str(cfactor), 2)
  219.   ' Mid(strout, 78, 8) = Right("        " & Str(csiz), 8)
  220.   ' s0 = ""
  221.   ' For xx = 0 To 255
  222.   '     If meth.ch(xx) = 0 Then exit for
  223.   '     s0 = s0 & Chr(meth.ch(xx))
  224.   ' Next xx
  225.  
  226.   '-- Do Not Modify Below!!!
  227.   uZipMessage = uZipMessage & strout & vbNewLine
  228.   uZipNumber = uZipNumber + 1
  229.  
  230. End Sub
  231.  
  232. '-- Callback For UNZIP32.DLL - Print Message Function
  233. Public Function UZDLLPrnt(ByRef fname As UNZIPCBChar, ByVal x As Long) As Long
  234.  
  235.   Dim s0 As String
  236.   Dim xx As Long
  237.  
  238.   '-- Always Put This In Callback Routines!
  239.   On Error Resume Next
  240.  
  241.   s0 = ""
  242.  
  243.   '-- Gets The UNZIP32.DLL Message For Displaying.
  244.   For xx = 0 To x - 1
  245.     If fname.ch(xx) = 0 Then Exit For
  246.     s0 = s0 & Chr(fname.ch(xx))
  247.   Next
  248.  
  249.   '-- Assign Zip Information
  250.   If Mid$(s0, 1, 1) = vbLf Then s0 = vbNewLine ' Damn UNIX :-)
  251.   uZipInfo = uZipInfo & s0
  252.  
  253.   UZDLLPrnt = 0
  254.  
  255. End Function
  256.  
  257. '-- Callback For UNZIP32.DLL - DLL Service Function
  258. Public Function UZDLLServ(ByRef mname As UNZIPCBChar, ByVal x As Long) As Long
  259.  
  260.     Dim s0 As String
  261.     Dim xx As Long
  262.     
  263.     '-- Always Put This In Callback Routines!
  264.     On Error Resume Next
  265.     
  266.     s0 = ""
  267.     '-- Get Zip32.DLL Message For processing
  268.     For xx = 0 To x - 1
  269.         If mname.ch(xx) = 0 Then Exit For
  270.         s0 = s0 + Chr(mname.ch(xx))
  271.     Next
  272.     ' At this point, s0 contains the message passed from the DLL
  273.     ' It is up to the developer to code something useful here :)
  274.     UZDLLServ = 0 ' Setting this to 1 will abort the zip!
  275.  
  276. End Function
  277.  
  278. '-- Callback For UNZIP32.DLL - Password Function
  279. Public Function UZDLLPass(ByRef p As UNZIPCBCh, _
  280.   ByVal n As Long, ByRef m As UNZIPCBCh, _
  281.   ByRef Name As UNZIPCBCh) As Integer
  282.  
  283.   Dim prompt     As String
  284.   Dim xx         As Integer
  285.   Dim szpassword As String
  286.  
  287.   '-- Always Put This In Callback Routines!
  288.   On Error Resume Next
  289.  
  290.   UZDLLPass = 1
  291.  
  292.   If uVbSkip = 1 Then Exit Function
  293.  
  294.   '-- Get The Zip File Password
  295.   szpassword = InputBox("Please Enter The Password!")
  296.  
  297.   '-- No Password So Exit The Function
  298.   If szpassword = "" Then
  299.     uVbSkip = 1
  300.     Exit Function
  301.   End If
  302.  
  303.   '-- Zip File Password So Process It
  304.   For xx = 0 To 255
  305.     If m.ch(xx) = 0 Then
  306.       Exit For
  307.     Else
  308.       prompt = prompt & Chr(m.ch(xx))
  309.     End If
  310.   Next
  311.  
  312.   For xx = 0 To n - 1
  313.     p.ch(xx) = 0
  314.   Next
  315.  
  316.   For xx = 0 To Len(szpassword) - 1
  317.     p.ch(xx) = Asc(Mid(szpassword, xx + 1, 1))
  318.   Next
  319.  
  320.   p.ch(xx) = Chr(0) ' Put Null Terminator For C
  321.  
  322.   UZDLLPass = 0
  323.  
  324. End Function
  325.  
  326. '-- Callback For UNZIP32.DLL - Report Function To Overwrite Files.
  327. '-- This Function Will Display A MsgBox Asking The User
  328. '-- If They Would Like To Overwrite The Files.
  329. Public Function UZDLLRep(ByRef fname As UNZIPCBChar) As Long
  330.  
  331.   Dim s0 As String
  332.   Dim xx As Long
  333.  
  334.   '-- Always Put This In Callback Routines!
  335.   On Error Resume Next
  336.  
  337.   UZDLLRep = 100 ' 100 = Do Not Overwrite - Keep Asking User
  338.   s0 = ""
  339.  
  340.   For xx = 0 To 255
  341.     If fname.ch(xx) = 0 Then xx = 99999 Else s0 = s0 & Chr(fname.ch(xx))
  342.   Next
  343.  
  344.   '-- This Is The MsgBox Code
  345.   xx = MsgBox("Overwrite " & s0 & "?", vbExclamation & vbYesNoCancel, _
  346.               "VBUnZip32 - File Already Exists!")
  347.  
  348.   If xx = vbNo Then Exit Function
  349.  
  350.   If xx = vbCancel Then
  351.     UZDLLRep = 104       ' 104 = Overwrite None
  352.     Exit Function
  353.   End If
  354.  
  355.   UZDLLRep = 102         ' 102 = Overwrite 103 = Overwrite All
  356.  
  357. End Function
  358.  
  359. '-- ASCIIZ To String Function
  360. Public Function szTrim(szString As String) As String
  361.  
  362.   Dim pos As Integer
  363.   Dim ln  As Integer
  364.  
  365.   pos = InStr(szString, Chr(0))
  366.   ln = Len(szString)
  367.  
  368.   Select Case pos
  369.     Case Is > 1
  370.       szTrim = Trim(Left(szString, pos - 1))
  371.     Case 1
  372.       szTrim = ""
  373.     Case Else
  374.       szTrim = Trim(szString)
  375.   End Select
  376.  
  377. End Function
  378.  
  379. '-- Main UNZIP32.DLL UnZip32 Subroutine
  380. '-- (WARNING!) Do Not Change!
  381. Public Sub VBUnZip32()
  382.  
  383.   Dim retcode As Long
  384.   Dim MsgStr As String
  385.  
  386.   '-- Set The UNZIP32.DLL Options
  387.   '-- (WARNING!) Do Not Change
  388.   UZDCL.ExtractOnlyNewer = uExtractNewer     ' 1 = Extract Only Newer
  389.   UZDCL.SpaceToUnderscore = uSpaceUnderScore ' 1 = Convert Space To Underscore
  390.   UZDCL.PromptToOverwrite = uPromptOverWrite ' 1 = Prompt To Overwrite Required
  391.   UZDCL.fQuiet = uQuiet                      ' 2 = No Messages 1 = Less 0 = All
  392.   UZDCL.ncflag = uWriteStdOut                ' 1 = Write To Stdout
  393.   UZDCL.ntflag = uTestZip                    ' 1 = Test Zip File
  394.   UZDCL.nvflag = uExtractList                ' 0 = Extract 1 = List Contents
  395.   UZDCL.nUflag = uExtractOnlyNewer           ' 1 = Extract Only Newer
  396.   UZDCL.nzflag = uDisplayComment             ' 1 = Display Zip File Comment
  397.   UZDCL.ndflag = uHonorDirectories           ' 1 = Honour Directories
  398.   UZDCL.noflag = uOverWriteFiles             ' 1 = Overwrite Files
  399.   UZDCL.naflag = uConvertCR_CRLF             ' 1 = Convert CR To CRLF
  400.   UZDCL.nZIflag = uVerbose                   ' 1 = Zip Info Verbose
  401.   UZDCL.C_flag = uCaseSensitivity            ' 1 = Case insensitivity, 0 = Case Sensitivity
  402.   UZDCL.fPrivilege = uPrivilege              ' 1 = ACL 2 = Priv
  403.   UZDCL.Zip = uZipFileName                   ' ZIP Filename
  404.   UZDCL.ExtractDir = uExtractDir             ' Extraction Directory, NULL If Extracting
  405.                                              ' To Current Directory
  406.  
  407.   '-- Set Callback Addresses
  408.   '-- (WARNING!!!) Do Not Change
  409.   UZUSER.UZDLLPrnt = FnPtr(AddressOf UZDLLPrnt)
  410.   UZUSER.UZDLLSND = 0&    '-- Not Supported
  411.   UZUSER.UZDLLREPLACE = FnPtr(AddressOf UZDLLRep)
  412.   UZUSER.UZDLLPASSWORD = FnPtr(AddressOf UZDLLPass)
  413.   UZUSER.UZDLLMESSAGE = FnPtr(AddressOf UZReceiveDLLMessage)
  414.   UZUSER.UZDLLSERVICE = FnPtr(AddressOf UZDLLServ)
  415.  
  416.   '-- Set UNZIP32.DLL Version Space
  417.   '-- (WARNING!!!) Do Not Change
  418.   With UZVER
  419.     .structlen = Len(UZVER)
  420.     .beta = Space(9) & vbNullChar
  421.     .date = Space(19) & vbNullChar
  422.     .zlib = Space(9) & vbNullChar
  423.   End With
  424.  
  425.   '-- Get Version
  426.   Call UzpVersion2(UZVER)
  427.  
  428.   '--------------------------------------
  429.   '-- You Can Change This For Displaying
  430.   '-- The Version Information!
  431.   '--------------------------------------
  432.   MsgStr$ = "DLL Date: " & szTrim(UZVER.date)
  433.   MsgStr$ = MsgStr$ & vbNewLine$ & "Zip Info: " & Hex(UZVER.zipinfo(1)) & "." & _
  434.        Hex(UZVER.zipinfo(2)) & Hex(UZVER.zipinfo(3))
  435.   MsgStr$ = MsgStr$ & vbNewLine$ & "DLL Version: " & Hex(UZVER.windll(1)) & "." & _
  436.        Hex(UZVER.windll(2)) & Hex(UZVER.windll(3))
  437.   MsgStr$ = MsgStr$ & vbNewLine$ & "--------------"
  438.   '-- End Of Version Information.
  439.  
  440.   '-- Go UnZip The Files! (Do Not Change Below!!!)
  441.   '-- This Is The Actual UnZip Routine
  442.   retcode = Wiz_SingleEntryUnzip(uNumberFiles, uZipNames, uNumberXFiles, _
  443.                                  uExcludeNames, UZDCL, UZUSER)
  444.   '---------------------------------------------------------------
  445.  
  446.   '-- If There Is An Error Display A MsgBox!
  447.   If retcode <> 0 Then MsgBox retcode
  448.  
  449.   '-- You Can Change This As Needed!
  450.   '-- For Compression Information
  451.   MsgStr$ = MsgStr$ & vbNewLine$ & "Only Shows If uExtractList = 1 List Contents"
  452.   MsgStr$ = MsgStr$ & vbNewLine$ & "--------------"
  453.   MsgStr$ = MsgStr$ & vbNewLine$ & "Comment         : " & UZUSER.cchComment
  454.   MsgStr$ = MsgStr$ & vbNewLine$ & "Total Size Comp : " & UZUSER.TotalSizeComp
  455.   MsgStr$ = MsgStr$ & vbNewLine$ & "Total Size      : " & UZUSER.TotalSize
  456.   MsgStr$ = MsgStr$ & vbNewLine$ & "Compress Factor : %" & UZUSER.CompFactor
  457.   MsgStr$ = MsgStr$ & vbNewLine$ & "Num Of Members  : " & UZUSER.NumMembers
  458.   MsgStr$ = MsgStr$ & vbNewLine$ & "--------------"
  459.  
  460.   VBUnzFrm.MsgOut.Text = VBUnzFrm.MsgOut.Text & MsgStr$ & vbNewLine$
  461. End Sub
  462.