Select, Zip, and Email Excel files

[oam]

I have a requirement to download two Excel files per day and save to a server folder, zip the file(s), and email the zipped file(s). I have been working with Ron de Bruin’s “Zip file(s) with the default Windows zip program” macros from his website and he has two macros that do half each of what I need. One of the macros called “Browse to the folder you want and select the file or files” allows you to navigate to the folder, select the file(s), zip the file(s), and save the zipped files which is part of the process I need but I do not need to save the zipped file(s) because I have already saved the Excel file(s) to the server. The other macro Ron has is an email macro which zips and emails the current Active Worksheet.

What I would like to know is there a way to combine both macros to allow the user to navigate to a folder, select the required file(s), zip the file(s), and email the newly zipped file(s) or is there another way to complete the same process but with a different macro(s)?

I can post Ron's macros if it would help but you can go to his website and see them here:
http://www.rondebruin.nl/win/s7/win001.htm

Thanks for any and all help.

[ranman256]

Cant you could loose the zip macro? Set the EMAIL to do this, then the user need only pick the files.

[oam]

The Zip and Email macro from Ron de Bruin is used to zip the ActiveWorkbook and email but what I needto do is have the user select the files, zip the files and email the files. The size of the files requires me to zip the files before sending andthat is what the receiver is expecting.

[westconn1]

I do not need to save the zipped file(s)
you would have to save the zip file, but can delete after the email has been sent, you would need to wait until sending is complete

you can use a shell object namespace to add files to a zip file, create a new zip file then add the selected files to it, then email

[oam]

The code below works for zipping all the files in a folder, creating an email, and saving the zipped files to central location.
I posting it for information but the credit goes to Ron de Bruin’s macros he and his comrades have created.

Thank you for all your feedback and thank you Ron de Bruin.






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
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 = Sheets("Lookup").Range("D12").Value 'New file name
' DefPath = Application.DefaultFilePath
' If Right(DefPath, 1) <> "\" Then
' DefPath = DefPath & "\"
' End If

'FolderName = "Z:\ZIP Files\" '<< Change

'strDate = Format(Now, "dd mmmm yyyy")
FileNameZip = Sheets("Lookup").Range("D16").Value 'New file name
'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:00"))
Loop
On Error GoTo 0
End If
Next iCtr

Call Mail_Workbook_Outlook
Call Delete_Manifest_Files

'MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
Sub Mail_Workbook_Outlook()
'Working in Excel 2000-2013

Dim OutApp As Object
Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "<b><p style=font-family:times new roman;font-size:'14'>Good Afternoon,</font></b>" & "<br>" & "<br>" & _
"<p style=font-family:times new roman;font-size:'12'>Your Message.</font>" & "<br>" & "<br>" & _
"<p style=color:rgb(0,0,0);font-family:times new roman;font-size:'12'>Thank you,</font>" & "<br>" & "<br>"

SigString = "C:\Your Path" & Environ("username") & _
"\Application Data\Microsoft\Signatures\Signature.htm"

If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

On Error Resume Next
With OutMail
.To = Sheets("Lookup").Range("D7")
.Cc = ""
.BCc = ""
.Subject = Sheets("Lookup").Range("D10")
.HTMLBody = strbody & "<br>" & Signature
.Attachments.Add Sheets("Lookup").Range("D16").Value
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function