Creating Zip file from within VB 6.0

I want to add an Export menu option to my app that will take every file with a .txt extension in the directory that the App is running and zip it up into one file.  I would like the user to be able to assign the drive and name to the output file.

I'm not sure how to do this from within VB.  Any ideas?

On the other side I also want to add an Import  menu option which will allow the user to find this zipped file wherever it is, unzip it and then overlay the corrsponding .TXT files wherever they want to put them.
LVL 1
mlcktmguyAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ashutosh VyasFounder, InitQubeCommented:
This might not be exactly wht you need but could help you out
http://www.vbaccelerator.com/home/VB/Code/Libraries/Compression/Introduction_to_the_Info-ZIP_Libraries/article.asp

Moreover try getting the information on Info Zip it might have some utilities there.

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
DhaestCommented:
See for information:

http://www.vbaccelerator.com/codelib/zip/zipvb.htm

Function winZipfile
   zipIT = "C:\program files\winzip\WINzip32 -a " '*** Added one space at the end after -a
   target = App.Path & "\test.zip "'*** Added one space at the end after .zip
   Shell (zipIT & target & SelectedFile)
End Function
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

anvCommented:
add following code in a class module..

'---------------------------------------------------------------------------------------
'
' CompressedFolder (CompressedFolder.cls)
'
'---------------------------------------------------------------------------------------
'
Option Explicit

Private m_oStorage As IStorage

Enum FileInfo
   Filename
   FileType
   PackedSize
   HasAPassword
   Method
   Size
   Ratio
   Date
   CRC32
End Enum

'---------------------------------------------------------------------------------------
' Procedure : CloseZip
' Purpose   : Saves changes and closes the file
'---------------------------------------------------------------------------------------
'
Public Sub CloseZip()
   
   m_oStorage.Commit
   Set m_oStorage = Nothing
   
End Sub

Public Sub CompressFile( _
   ByVal Filename As String)
Dim oDT As IDropTarget
Dim oDO As IDataObject
Dim oSF As IShellFolder
Dim tIID_IDropTarget As UUID
Dim lPtr As Long

   ' The storage object doesn't seems to work :(
   ' To compress the file we will use the
   ' IDropTarget interface to simulate a drag
   ' and drop operation
   
   ' Initialize IDs
   CLSIDFromString "{00000122-0000-0000-C000-000000000046}", tIID_IDropTarget
   
   ' Get the folder IDropTarget interface
   Set oSF = m_oStorage
   lPtr = oSF.CreateViewObject(0, tIID_IDropTarget)
   MoveMemory oDT, lPtr, 4&
   
   ' Get the file IDataObject interface
   Set oDO = getFileDataObject(Filename)
   
   ' Simulate a drag-drop operation
   oDT.DragEnter oDO, vbKeyLButton, 0, 0, DROPEFFECT_COPY
   oDT.Drop oDO, vbKeyLButton, 0, 0, DROPEFFECT_COPY

End Sub

'---------------------------------------------------------------------------------------
' Procedure : CreateZip
' Purpose   : Creates a .zip file
'---------------------------------------------------------------------------------------
'
Public Sub CreateZip( _
   ByVal Filename As String)
Dim lFF As Long
Dim abData(0 To 21) As Byte

   On Error Resume Next
   
   ' Delete file if exists
   Kill Filename
   
   On Error GoTo 0
   
   ' Write an empty .zip file
   lFF = FreeFile
   Open Filename For Binary As lFF
   abData(0) = &H50
   abData(1) = &H4B
   abData(2) = &H5
   abData(3) = &H6
   Put lFF, , abData
   Close lFF
   
   ' Open the zip
   OpenZip Filename
   
End Sub

'---------------------------------------------------------------------------------------
' Procedure : DeleteFile
' Purpose   : Removes a file from the .zip file
'---------------------------------------------------------------------------------------
'
Public Sub DeleteFile(ByVal Name As String)

   m_oStorage.DestroyElement Name
   
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ExtractFile
' Purpose   : Extracts a file from the zip
'---------------------------------------------------------------------------------------
'
Public Sub ExtractFile( _
   ByVal Name As String, _
   ByVal DestFolder As String)
Dim oStream As IStream
Dim tStat As STATSTG
Dim abData() As Byte
Dim lFF As Long

   ' Open the stream
   Set oStream = m_oStorage.OpenStream( _
      Name, 0, _
      STGM_READ Or STGM_SHARE_EXCLUSIVE)
   
   ' Get the stream info
   oStream.Stat tStat, STATFLAG_DEFAULT
   
   ' Initialize the array
   ReDim abData(0 To tStat.cbSize * 10000 - 1)
         
   ' Read the data from the stream
   oStream.Read abData(0), tStat.cbSize * 10000
         
   ' Close the stream
   Set oStream = Nothing
   
   ' Save the data to a file
   lFF = FreeFile()
   Open DestFolder & "\" & Name For Binary As lFF
   Put lFF, , abData
   Close lFF
         
End Sub

'---------------------------------------------------------------------------------------
' Procedure : GetFileInfo
' Purpose   : Returns file information
'---------------------------------------------------------------------------------------
'
Public Function GetFileInfo( _
   ByVal Filename As String, _
   ByVal Index As FileInfo) As String
Dim oSF As IShellFolder2
Dim tSD As SHELLDETAILS
Dim lPidl As Long

   If Index < 0 Or Index > CRC32 Then Err.Raise 5
   
   ' Get the IShellFolder2 interface
   Set oSF = m_oStorage
   
   ' Get the file PIDL
   oSF.ParseDisplayName 0, 0, StrPtr(Filename), 0, lPidl, 0
   
   ' Get the column info
   oSF.GetDetailsOf lPidl, Index, tSD
   
   ' Convert the info to string
   GetFileInfo = SysAllocString(StrRetToStr(VarPtr(tSD.Str), lPidl))
   
   ' Release the PIDL
   CoTaskMemFree lPidl
   
End Function

'---------------------------------------------------------------------------------------
' Procedure : GetFiles
' Purpose   : Enumerates files contained in this folder
'---------------------------------------------------------------------------------------
'
Public Function GetFiles() As String()
Dim oEnum As IEnumSTATSTG
Dim tStat As STATSTG
Dim asFiles() As String
Dim lIdx As Long

   Set oEnum = m_oStorage.EnumElements
   
   Do While oEnum.Next(1, tStat) = S_OK
     
      ' Files are stored as streams
      If tStat.Type = STGTY_STREAM Then
     
         ' Resize the array
         ReDim Preserve asFiles(0 To lIdx)
         
         ' Get the file name
         asFiles(lIdx) = SysAllocString(tStat.pwcsName)
         
         ' Release the pointer
         CoTaskMemFree tStat.pwcsName
         
         ' Increment the index
         lIdx = lIdx + 1
         
      End If
     
   Loop

   ' Return the array
   GetFiles = asFiles

End Function

'---------------------------------------------------------------------------------------
' Procedure : GetFolders
' Purpose   : Enumerates folders contained in this folder
'---------------------------------------------------------------------------------------
'
Public Function GetFolders() As String()
Dim oEnum As IEnumSTATSTG
Dim tStat As STATSTG
Dim asFolders() As String
Dim lIdx As Long

   Set oEnum = m_oStorage.EnumElements
   
   Do While oEnum.Next(1, tStat) = S_OK
     
      ' Folders are stored as storages
      If tStat.Type = STGTY_STORAGE Then
     
         ' Resize the array
         ReDim Preserve asFolders(0 To lIdx)
         
         ' Get the file name
         asFolders(lIdx) = SysAllocString(tStat.pwcsName)
         
         ' Release the pointer
         CoTaskMemFree tStat.pwcsName
         
         ' Increment the index
         lIdx = lIdx + 1
         
      End If
     
   Loop

   ' Return the array
   GetFolders = asFolders
   
End Function

'---------------------------------------------------------------------------------------
' Procedure : OpenSubFolder
' Purpose   : Opens a subfolder
'---------------------------------------------------------------------------------------
'
Public Function OpenSubFolder( _
   ByVal Name As String) As CompressedFolder
Dim oFolder As IStorage

   ' Open the storage
   Set oFolder = m_oStorage.OpenStorage( _
      Name, 0, _
      STGM_READWRITE Or STGM_SHARE_EXCLUSIVE)
   
   ' Create a new CompressedFolder object
   Set OpenSubFolder = New CompressedFolder
   
   ' Initialize the object
   OpenSubFolder.setStorage oFolder

End Function

'---------------------------------------------------------------------------------------
' Procedure : OpenZip
' Purpose   : Opens a zip file
'---------------------------------------------------------------------------------------
'
Public Sub OpenZip(ByVal Filename As String)
Dim oPF As IPersistFile

   Set m_oStorage = Nothing
   
   ' Create the CompressedFolder object
   Set m_oStorage = CreateObject("CompressedFolder")
   
   ' Get the IPersistFile interface
   ' and load the zip file
   Set oPF = m_oStorage
   oPF.Load Filename, STGM_READWRITE Or STGM_SHARE_EXCLUSIVE
   
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ShowAddPassword
' Purpose   : Shows the add password dialog
'---------------------------------------------------------------------------------------
'
Public Sub ShowAddPassword()
Dim oCtxMenu As IContextMenu
Dim tICI As CMINVOKECOMMANDINFO

   Set oCtxMenu = getContextMenu
   
   tICI.cbSize = Len(tICI)
   tICI.lpVerb = 1
   oCtxMenu.InvokeCommand tICI
   
End Sub

'---------------------------------------------------------------------------------------
' Procedure : ShowExtractAll
' Purpose   : Shows the extract all dialog
'---------------------------------------------------------------------------------------
'
Public Sub ShowExtractAll()
Dim oCtxMenu As IContextMenu
Dim tICI As CMINVOKECOMMANDINFO

   Set oCtxMenu = getContextMenu
   
   tICI.cbSize = Len(tICI)
   tICI.lpVerb = 0
   oCtxMenu.InvokeCommand tICI
   
End Sub

'---------------------------------------------------------------------------------------
' Procedure : getContextMenu
' Purpose   : Returns the folder context menu handler
'---------------------------------------------------------------------------------------
'
Private Function getContextMenu() As IContextMenu
Dim oSF As IShellFolder
Dim tIID_IContextMenu As UUID
Dim lPtr As Long

   ' Initialize IDs
   CLSIDFromString IIDSTR_IContextMenu, tIID_IContextMenu
   
   ' Get the folder object
   Set oSF = m_oStorage
   
   ' Get the context menu
   lPtr = oSF.CreateViewObject(0, tIID_IContextMenu)
   MoveMemory getContextMenu, lPtr, 4&

End Function

'---------------------------------------------------------------------------------------
' Procedure : getFileDataObject
' Purpose   : Returns the IDataObject interface for a
'             file
'---------------------------------------------------------------------------------------
'
Private Function getFileDataObject( _
   ByVal Filename As String) As IDataObject
Dim tIID_IDataObject As UUID
Dim tIID_IShellFolder As UUID
Dim oDesktop As IShellFolder
Dim oParent As IShellFolder
Dim oUnk As IUnknown
Dim sFolder As String
Dim lPidl As Long
Dim lPtr As Long

   ' Intialize IDs
   CLSIDFromString "{0000010e-0000-0000-C000-000000000046}", tIID_IDataObject
   CLSIDFromString IIDSTR_IShellFolder, tIID_IShellFolder
   
   sFolder = Left$(Filename, InStrRev(Filename, "\") - 1)
   Filename = Mid$(Filename, Len(sFolder) + 2)
   
   ' Get the parent folder object
   Set oDesktop = SHGetDesktopFolder
   
   ' Get the parent folder IDL
   oDesktop.ParseDisplayName 0, 0, StrPtr(sFolder), lPtr, lPidl, 0
   
   ' Get the parent folder object
   oDesktop.BindToObject lPidl, 0, tIID_IShellFolder, lPtr
   MoveMemory oParent, lPtr, 4&
   
   ' Release the PIDL
   CoTaskMemFree lPidl
   
   ' Get the file PIDL
   oParent.ParseDisplayName 0, 0, StrPtr(Filename), 0, lPidl, 0
   
   ' Get the file IDataObject
   lPtr = oParent.GetUIObjectOf(0, 1, lPidl, tIID_IDataObject, 0)
   MoveMemory oUnk, lPtr, 4&
   
   ' Release the file PIDL
   CoTaskMemFree lPidl

   ' Return the file IDataObject
   Set getFileDataObject = oUnk
   
End Function

'---------------------------------------------------------------------------------------
' Procedure : setStorage
' Purpose   : Sets the IStorage object. This method is
'             called on a new object when OpenSubFolder
'             is called to open a subfolder
'---------------------------------------------------------------------------------------
'
Friend Sub setStorage(ByVal Stg As IStorage)
   Set m_oStorage = Stg
End Sub

Private Sub Class_Terminate()

   If Not m_oStorage Is Nothing Then CloseZip
   
End Sub
0
_agj_Commented:
searching for sawzip wud be useful. its a freeware zipping dll...
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.