Urgent!! Zipping Files Programatically Ocx/Dll and fast like Winzip

Create a project from the following and place VBZIP in the same DIR :

Class Module ( cZip.cls )
------------------------------------------
Option Explicit

Public Enum EZPMsgLevel
   ezpAllMessages = 0
   ezpPartialMessages = 1
   ezpNoMessages = 2
End Enum

Public Event Cancel(ByVal sMsg As String, ByRef bCancel As Boolean)
Public Event PasswordRequest(ByRef sPassword As String, ByRef bCancel As Boolean)
Public Event Progress(ByVal lCount As Long, ByVal sMsg As String)


Private m_tZPOPT As ZPOPT
Private m_sFileName As String
Private m_sFileSpecs() As String
Private m_iCount As Long

Public Property Get ZipFile() As String
   ZipFile = m_sFileName
End Property
Public Property Let ZipFile(ByVal sFileName As String)
   m_sFileName = sFileName
End Property
Public Property Get BasePath() As String
   BasePath = m_tZPOPT.szRootDir
End Property
Public Property Let BasePath(ByVal sBasePath As String)
   m_tZPOPT.szRootDir = sBasePath
End Property
Public Property Get Encrpyt() As Boolean
   Encrypt = Not (m_tZPOPT.fEncrypt = 0)
End Property
Public Property Let Encrypt(ByVal bState As Boolean)
   m_tZPOPT.fEncrypt = Abs(bState)
End Property
Public Property Get IncludeSystemAndHiddenFiles() As Boolean
    IncludeSystemAndHiddenFiles = Not (m_tZPOPT.fSystem = 0)
End Property
Public Property Let IncludeSystemAndHiddenFiles(ByVal bState As Boolean)
   m_tZPOPT.fSystem = Abs(bState)
End Property
Public Property Get StoreVolumeLabel() As Boolean
    StoreVolumeLabel = Not (m_tZPOPT.fVolume = 0)
End Property
Public Property Let StoreVolumeLabel(ByVal bState As Boolean)
   m_tZPOPT.fVolume = Abs(bState)
End Property
Public Property Get StoreDirectories() As Boolean
   StoreDirectories = Not (m_tZPOPT.fNoDirEntries = 0)
End Property
Public Property Let StoreDirectories(ByVal bState As Boolean)
   m_tZPOPT.fNoDirEntries = Abs(Not (bState))
End Property
Public Property Get StoreFolderNames() As Boolean
   StoreFolderNames = (m_tZPOPT.fJunkDir = 0)
End Property
Public Property Let StoreFolderNames(ByVal bState As Boolean)
   m_tZPOPT.fJunkDir = Abs(Not (bState))
End Property
Public Property Get RecurseSubDirs() As Boolean
   RecurseSubDirs = Not (m_tZPOPT.fRecurse = 0)
End Property
Public Property Let RecurseSubDirs(ByVal bState As Boolean)
   If bState Then
      m_tZPOPT.fRecurse = 2
   Else
      m_tZPOPT.fRecurse = 0
   End If
End Property

Public Property Get UpdateOnlyIfNewer() As Boolean
    UpdateOnlyIfNewer = Not (m_tZPOPT.fUpdate = 0)
End Property
Public Property Let UpdateOnlyIfNewer(ByVal bState As Boolean)
    m_tZPOPT.fUpdate = Abs(bState)
End Property
Public Property Get FreshenFiles() As Boolean
    FreshenFiles = Not (m_tZPOPT.fFreshen = 0)
End Property
Public Property Let FreshenFiles(ByVal bState As Boolean)
    m_tZPOPT.fUpdate = Abs(bState)
End Property
Public Property Get MessageLevel() As EZPMsgLevel
   If Not (m_tZPOPT.fVerbose = 0) Then
      MessageLevel = ezpAllMessages
   ElseIf Not (m_tZPOPT.fQuiet = 0) Then
      MessageLevel = ezpPartialMessages
   Else
      MessageLevel = ezpNoMessages
   End If
End Property
Public Property Let MessageLevel(ByVal eLevel As EZPMsgLevel)
   Select Case eLevel
   Case ezpPartialMessages
      m_tZPOPT.fQuiet = 1
      m_tZPOPT.fVerbose = 0
   Case ezpNoMessages
      m_tZPOPT.fQuiet = 0
      m_tZPOPT.fVerbose = 0
   Case ezpAllMessages
      m_tZPOPT.fQuiet = 0
      m_tZPOPT.fVerbose = 1
   End Select
End Property
Public Property Get ConvertCRLFToLF() As Boolean
   ConvertCRLFToLF = (m_tZPOPT.fCRLF_LF <> 0)
End Property
Public Property Let ConvertCRLFToLF(ByVal bState As Boolean)
   m_tZPOPT.fCRLF_LF = Abs(bState)
End Property
Public Property Get ConvertLFToCRLF() As Boolean
   ConvertLFToCRLF = (m_tZPOPT.fLF_CRLF <> 0)
End Property
Public Property Let ConvertLFToCRLF(ByVal bState As Boolean)
   m_tZPOPT.fLF_CRLF = Abs(bState)
End Property

Friend Sub ProgressReport( _
      ByVal sMsg As String _
   )
   RaiseEvent Progress(1, sMsg)
End Sub
Friend Sub PasswordRequest( _
      ByRef sPassword As String, _
      ByRef bCancel As Boolean _
   )
   RaiseEvent PasswordRequest(sPassword, bCancel)
End Sub
Friend Sub Service( _
      ByVal sMsg As String, _
      ByRef bCancel As Boolean _
   )
   RaiseEvent Cancel(sMsg, bCancel)
End Sub
Public Sub ClearFileSpecs()
   m_iCount = 0
   Erase m_sFileSpecs()
End Sub
Public Function AddFileSpec(ByVal sSpec As String) As Long
   m_iCount = m_iCount + 1
   ReDim Preserve m_sFileSpecs(1 To m_iCount) As String
   m_sFileSpecs(m_iCount) = sSpec
End Function
Public Property Get FileSpecCount() As Long
   FileSpecCount = m_iCount
End Property
Public Property Get FileSpec(ByVal nIndex As Long)
   FileSpec = m_sFileSpecs(nIndex)
End Property
Public Property Get AllowAppend() As Boolean
   AllowAppend = (m_tZPOPT.fGrow = 1)
End Property
Public Property Let AllowAppend(ByVal bState As Boolean)
   m_tZPOPT.fGrow = Abs(bState)
End Property
Public Sub Zip()
   mZip.VBZip Me, m_tZPOPT, m_sFileSpecs(), m_iCount
End Sub
Public Sub Delete()
   m_tZPOPT.fDeleteEntries = 1
   mZip.VBZip Me, m_tZPOPT, m_sFileSpecs(), m_iCount
   m_tZPOPT.fDeleteEntries = 0
End Sub

Private Sub Class_Initialize()
   StoreDirectories = False
   StoreFolderNames = False
   RecurseSubDirs = False
End Sub
--------------------------------------------



Module (mzip.bas)
---------------------------------------------
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Type ZIPnames
    s(0 To 1023) As String
End Type
Private Type CBChar
    ch(0 To 4096) As Byte
End Type
Private Type CBCh
    ch(0 To 255) As Byte
End Type
Private Type ZIPUSERFUNCTIONS
    lPtrPrint As Long
    lptrPassword As Long
    lptrComment As Long
    lptrService As Long
End Type

Public Type ZPOPT
  Date           As String
  szRootDir      As String
  szTempDir      As String
  fTemp          As Long
  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
  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
  fRecurse       As Long
  fRepair        As Long
  flevel         As Byte
End Type
Private Declare Function ZpInit Lib "vbzip10.dll" (ByRef tUserFn As ZIPUSERFUNCTIONS) As Long
Private Declare Function ZpSetOptions Lib "vbzip10.dll" (ByRef tOpts As ZPOPT) As Long
Private Declare Function ZpGetOptions Lib "vbzip10.dll" () As ZPOPT
Private Declare Function ZpArchive Lib "vbzip10.dll" (ByVal argc As Long, ByVal funame As String, ByRef argv As ZIPnames) As Long
Private m_cZip As cZip
Private m_bCancel As Boolean

Private Function plAddressOf(ByVal lPtr As Long) As Long
   plAddressOf = lPtr
End Function

Public Function VBZip( _
      cZipObject As cZip, _
      tZPOPT As ZPOPT, _
      sFileSpecs() As String, _
      iFileCount As Long _
   ) As Long
Dim tUser As ZIPUSERFUNCTIONS
Dim lR As Long
Dim i As Long
Dim sZipFile As String
Dim tZipName As ZIPnames

   m_bCancel = False
   Set m_cZip = cZipObject

   If Not Len(Trim$(m_cZip.BasePath)) = 0 Then
      ChDir m_cZip.BasePath
   End If
   tUser.lPtrPrint = plAddressOf(AddressOf ZipPrintCallback)
   tUser.lptrPassword = plAddressOf(AddressOf ZipPasswordCallback)
   tUser.lptrComment = plAddressOf(AddressOf ZipCommentCallback)
   tUser.lptrService = plAddressOf(AddressOf ZipServiceCallback)
   lR = ZpInit(tUser)
   lR = ZpSetOptions(tZPOPT)
   For i = 1 To iFileCount
      tZipName.s(i - 1) = sFileSpecs(i)
   Next i
   tZipName.s(i) = vbNullChar
   
   sZipFile = cZipObject.ZipFile
   lR = ZpArchive(iFileCount, sZipFile, tZipName)
   
   VBZip = lR

End Function

Private Function ZipServiceCallback(ByRef mname As CBChar, ByVal X As Long) As Long
Dim iPos As Long
Dim sInfo As String
Dim bCancel As Boolean
On Error Resume Next
   If X > 1 And X < 32000 Then
      ReDim b(0 To X) As Byte
      CopyMemory b(0), mname, X
      sInfo = StrConv(b, vbUnicode)
      iPos = InStr(sInfo, vbNullChar)
      If iPos > 0 Then
         sInfo = Left$(sInfo, iPos - 1)
      End If
      m_cZip.Service sInfo, bCancel
      If bCancel Then
         ZipServiceCallback = 1
      Else
         ZipServiceCallback = 0
      End If
   End If
End Function

Private Function ZipPrintCallback( _
      ByRef fname As CBChar, _
      ByVal X As Long _
   ) As Long
Dim iPos As Long
Dim sFIle As String
   On Error Resume Next
   If X > 1 And X < 32000 Then
      ReDim b(0 To X) As Byte
      CopyMemory b(0), fname, X
      sFIle = StrConv(b, vbUnicode)
      If iPos > 0 Then
         sFIle = Left$(sFIle, iPos - 1)
      End If
      ReplaceSection sFIle, "/", "\"
      m_cZip.ProgressReport sFIle
   End If
   ZipPrintCallback = 0
End Function

Private Function ZipCommentCallback( _
      ByRef s1 As CBChar _
   ) As CBChar
   On Error Resume Next
   s1.ch(0) = vbNullString
   ZipCommentCallback = s1
End Function

Private Function ZipPasswordCallback( _
      ByRef pwd As CBCh, _
      ByVal X As Long, _
      ByRef s2 As CBCh, _
      ByRef Name As CBCh _
   ) As Long

Dim bCancel As Boolean
Dim sPassword As String
Dim b() As Byte
Dim lSize As Long

On Error Resume Next
   ZipPasswordCallback = 1
   
   If m_bCancel Then
      Exit Function
   End If
   m_cZip.PasswordRequest sPassword, bCancel
   sPassword = Trim$(sPassword)
   If bCancel Or Len(sPassword) = 0 Then
      m_bCancel = True
      Exit Function
   End If
   lSize = Len(sPassword)
   If lSize > 254 Then
      lSize = 254
   End If
   b = StrConv(sPassword, vbFromUnicode)
   CopyMemory pwd.ch(0), b(0), lSize
   ZipPasswordCallback = 0
       
End Function

Private Function ReplaceSection(ByRef sString As String, ByVal sToReplace As String, ByVal sReplaceWith As String) As Long
Dim iPos As Long
Dim iLastPos As Long
   iLastPos = 1
   Do
      iPos = InStr(iLastPos, sString, "/")
      If (iPos > 1) Then
         Mid$(sString, iPos, 1) = "\"
         iLastPos = iPos + 1
      End If
   Loop While Not (iPos = 0)
   ReplaceSection = iLastPos

End Function




Form
---------------------------------------------------
Option Explicit
Private WithEvents m_cZ As cZip

Function ZipItUp(FileToCreate As String, FileToAdd As String)
    Set m_cZ = New cZip
    With m_cZ
    .ZipFile = FileToCreate
    .StoreFolderNames = False
    .RecurseSubDirs = False
    .ClearFileSpecs
    .AddFileSpec FileToAdd
    .Zip
    End With
End Function

Private Sub Form_Load()
    Call ZipItUp("c:\myfile.zip", "c:\myfile.txt")
End Sub

I can mail the project and DLL if you like ?