Hello, I have a working zip function that zips all files in a directory into one zip file. I need the function to zip only files I specify from a record set that contains file path/name of text files. I have tried to call the function and pass in values from a recordset but once it creates the zip it can't write over itself and crashes. Does anyone know of any way I accomplish my goal? It would be a lifesaver.
working code:
my test code (which does not work in several ways, may be best to just ignore this):
working code:
Code:
Function ZipFolder(varFolderName_SOURCE_COMPLETE As Variant, varFileName_DESTINATION_COMPLETE As Variant) As String
'Arguments should be like "C:\TestFolder", "C:\TestFile.zip"
'Function should be used like this:
'Dim strZipFolder_RETURNVALUE As String
' strZipFolder_RETURNVALUE = ZipFolder("C:\TestFolder", "C:\TestFile.zip")
' If Left(strZipFolder_RETURNVALUE, 7) <> "Success" Then ...
DoCmd.SetWarnings False
'On Error GoTo Error_Handler
Dim objFSO As New FileSystemObject
Dim objEmptyZIPFile As TextStream
Dim objShellApplication As Object
Dim objFile_DESTINATION As Variant
Dim objFolder_SOURCE As Variant
'Create an empty ZIP file
Set objEmptyZIPFile = objFSO.OpenTextFile(varFileName_DESTINATION_COMPLETE, ForAppending, True)
objEmptyZIPFile.Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0))
objEmptyZIPFile.Close
Set objEmptyZIPFile = Nothing
'Create Application object
Set objShellApplication = CreateObject("Shell.Application")
'Define Destination_File and Source_Filder
Set objFile_DESTINATION = objShellApplication.NameSpace(varFileName_DESTINATION_COMPLETE)
Set objFolder_SOURCE = objShellApplication.NameSpace(varFolderName_SOURCE_COMPLETE).Items
'Copy the files to the compressed folder
objFile_DESTINATION.CopyHere objFolder_SOURCE, 256
'Keep code waiting until compression is done and file is moved from cache to destination
Do Until objFile_DESTINATION.Items.Count = objFolder_SOURCE.Count
Wait
Loop
'Error_Handler:
'MsgBox Err.Number & " " & Err.Description
'Release objects
Set objFSO = Nothing
Set objShellApplication = Nothing
Set objFile_DESTINATION = Nothing
Set objFolder_SOURCE = Nothing
DoCmd.SetWarnings True
End Functionmy test code (which does not work in several ways, may be best to just ignore this):
Code:
Function procPROCESS1AND2() As String
'On Error GoTo error
DoCmd.SetWarnings False
'Move Files to zip directory
Dim rs As Recordset
Dim fso As New FileSystemObject
Dim strSource As String
Dim strDest As String
Dim strSql As String
Dim strZipFolder_RETURNVALUE As String
Dim objShellApplication As Object
Dim objFile_DESTINATION As Variant
Dim objFolder_SOURCE As Variant
strSql = "SELECT * FROM tblPROCESS1AND2"
Set rs = CurrentDb.OpenRecordset(strSql)
Do While Not rs.EOF
strSource = rs.Fields("Source").Value
strDest = rs.Fields("Destination").Value
Set objShellApplication = CreateObject("Shell.Application")
'Define Destination_File and Source_Filder
Set objFile_DESTINATION = objShellApplication.NameSpace(strDest)
Set objFolder_SOURCE = objShellApplication.NameSpace(strSource)
objFile_DESTINATION.CopyHere objFolder_SOURCE, 256
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
'Move Pugh.txt
'error:
'MsgBox Err.Number & " " & Err.Description
DoCmd.SetWarnings True
End Function
