[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Creating Zip file from within VB 6.0

Posted on 2004-11-02
6
Medium Priority
?
622 Views
Last Modified: 2008-01-09
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.
0
Comment
Question by:mlcktmguy
6 Comments
 
LVL 8

Accepted Solution

by:
Ashutosh Vyas earned 1000 total points
ID: 12480221
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
 
LVL 53

Expert Comment

by:Dhaest
ID: 12480435
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
 
LVL 10

Expert Comment

by:anv
ID: 12480606
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
LVL 10

Expert Comment

by:anv
ID: 12480612
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
 
LVL 6

Expert Comment

by:mmusante
ID: 12480703
0
 
LVL 7

Expert Comment

by:_agj_
ID: 12482559
searching for sawzip wud be useful. its a freeware zipping dll...
0

Featured Post

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
Suggested Courses
Course of the Month18 days, 20 hours left to enroll

834 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question