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.
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.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
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-
' 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
' 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.pwcsN
' 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.pwcsN
' 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("CompressedFo
' 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-
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
'-------------------------
'
' 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-
' 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
' 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.pwcsN
' 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.pwcsN
' 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("CompressedFo
' 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-
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
Yoc can also try this ... http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=52005&lngWId=1
searching for sawzip wud be useful. its a freeware zipping dll...
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