Zipping with VBA

[jfougerousse]

I have a database that I am working on and there is a macro that creates a text file backup in a folder on the users C:/. it creates 18 text files. what I am wanting to do is be able to have another process that runs but after creating the files I would like them all zipped together. I am at a loss, I have seen some information on creating a zip with vba but can't seem to adapt it to what I need. the code would need to generate the filename of MY choosing rather than let the user decide.

[Bob Phillips]

Show us the code that you tried and tell us where it doesn't do what you want.

[jfougerousse]

Actually here is the code I have.... this set actually lets the user determine where to save the file. this would be fine if it would create a zip file instead of a folder with the text files inside.


Private Sub cmdSaveAs_Click()
Dim intDecision As Integer
On Error GoTo Error_cmdSaveAs
'Opens a Treeview control that displays the directories in a computer
Dim lpIDList As Long
Dim sBuffer As String
Dim sNewDir As String
Dim sNewSaveBuffer As String
Dim sTempString As String
Dim szTitle As String
Dim tBrowseInfo As BrowseInfo
Dim sDateDir As String
Dim sNewFolder As String
szTitle = "Location to Save Data"
With tBrowseInfo
.hWndOwner = Me.hwnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)

Me.Form.Visible = False
MsgBox "Winstabs Data will be saved in " & vbCrLf & vbCrLf & _
sBuffer

Else

MsgBox "Export Action Canceled.", vbOKOnly, "Action Canceled by User."
Exit Sub

End If

sDateDir = "\WData" & DLookup("Year", "tblTreasID") & "_L" & _
DLookup("LocalNo", "tblTreasID") & "_" & Format(CStr(Right(Year(Now), 4)), "0000") & _
"-" & Format(CStr(Month(Now)), "00") & "-" & Format(CStr(Day(Now)), "00") & "_" & _
Format(CStr(Hour(Now)), "00") & "h" & Format(CStr(Minute(Now)), "00") & "m"
sNewDir = sBuffer & sDateDir

If Mid(sNewDir, 3, 2) = "\\" Then

sTempString = Left(sNewDir, 3) & Right(sNewDir, (Len(sNewDir) - 4))

sNewDir = sTempString
sTempString = ""

End If


MkDir sNewDir

DoCmd.Hourglass True
sNewSaveBuffer = sNewDir & "\wstabs01.txt"
DoCmd.TransferText acExportDelim, , "exportpopup", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs02.txt"
DoCmd.TransferText acExportDelim, , "tblMemberRecord", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs03.txt"
DoCmd.TransferText acExportDelim, , "tblBillingHistory", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs04.txt"
DoCmd.TransferText acExportDelim, , "tblInsurance", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs05.txt"
DoCmd.TransferText acExportDelim, , "tblE49", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs06.txt"
DoCmd.TransferText acExportDelim, , "ExportPayrollTax", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs07.txt"
DoCmd.TransferText acExportDelim, , "tblTransfers", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs08.txt"
DoCmd.TransferText acExportDelim, , "tblPayroll", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs09.txt"
DoCmd.TransferText acExportDelim, , "tblMileage", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs10.txt"
DoCmd.TransferText acExportDelim, , "tblCheckbook", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs11.txt"
DoCmd.TransferText acExportDelim, , "tblBilling", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs12.txt"
DoCmd.TransferText acExportDelim, , "tblBilling2", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs13.txt"
DoCmd.TransferText acExportDelim, , "tblTreasID", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs14.txt"
DoCmd.TransferText acExportDelim, , "tblTreasurer", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs16.txt"
DoCmd.TransferText acExportDelim, , "tblMinutes", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs17.txt"
DoCmd.TransferText acExportDelim, , "tblE49History", sNewSaveBuffer, True
sNewSaveBuffer = sNewDir & "\wstabs18.txt"
DoCmd.TransferText acExportDelim, , "tblBillingHistoryPg3", sNewSaveBuffer, True

DoCmd.Hourglass False

sNewFolder = Right(sDateDir, Len(sDateDir) - 1)

MsgBox "Files Exported Successfully to a Folder Named " & vbCrLf & vbCrLf & _
sNewFolder, vbOKOnly, "Export Complete - " & sNewDir

Me.Form.Visible = True

intDecision = _
MsgBox("Do you wish to make another Backup?", vbYesNo, "Backup Completed")

If intDecision = vbNo Then

DoCmd.Close

Else

Exit Sub

End If

Exit_cmdSaveAs:
Exit Sub

Error_cmdSaveAs:
' MsgBox Err.Description
Me.Form.Visible = True
Resume Exit_cmdSaveAs

End Sub

[Logit]

.
You can use this project ... I'm certain there are a few modifications you'll want to effect :



Option Explicit


Sub Zip_File_Or_Files()
Dim strDate As String, DefPath As String, sFName As String
Dim oApp As Object, iCtr As Long, I As Integer
Dim FName, vArr, FileNameZip

DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If


strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"


'Browse to the file(s), use the Ctrl key to select more files
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True, Title:="Select the files you want to zip")
If IsArray(FName) = False Then
'do nothing
Else
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
I = 0
For iCtr = LBound(FName) To UBound(FName)
vArr = Split97(FName(iCtr), "\")
sFName = vArr(UBound(vArr))
If bIsBookOpen(sFName) Then
MsgBox "You can't zip a file that is open!" & vbLf & _
"Please close it and try again: " & FName(iCtr)
Else
'Copy the file to the compressed folder
I = I + 1
oApp.Namespace(FileNameZip).CopyHere FName(iCtr)


'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = I
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
End If
Next iCtr


MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub


Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub




Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function




Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function


The complete project attached. As is, the code allows the user to select the folder then files to be zipped. You can hard code that to the present folder where all files are saved.
The zipped file is placed in the DOCUMENTS folder. That too can be edited for your purposes.

Cheers !

[jfougerousse]

Forgive the Noob question, Logit, I am having trouble getting this to work in access. what I would like to do is have a form with a button that loads your code. anytime I try to tie the code to the "on click" code builder it simply doesn't work

I am sorry for the new questions, I am a bit rusty with coding!

[Logit]

.
Sorry for the confusion. Excel VBA doesn't always work with ACCESS. It has been decades since I've messed with ACCESS ... hopefully someone else can assist you.

Anyone ??

[jfougerousse]

Thank you for the help anyway.. will work well when I am using excel!!!!

[PhilS]

I think Logit's sample code is coupled very tightly to Excel. E.g. the Application.Something-Methods need to be adjusted for Access, Workbook/Worksheet reference will not work, etc.

I published an extensive info on ZIP-Archives with VBA and the Shell32 library (http://codekabinett.com/rdumps.php?Lang=2&targetDoc=create-zip-archive-vba-shell32) (http://codekabinett.com/rdumps.php?Lang=2&targetDoc=create-zip-archive-vba-shell32)on my website. It is based on the same approach of using the built-in Shell32 libaray, but it is split into smaller and more digestible procedures, which should work in any VBA enabled application.