Option Explicit 
 
Private Declare Function OpenProcess _ 
    Lib "kernel32" ( _ 
    ByVal dwDesiredAccess As Long, _ 
    ByVal bInheritHandle As Long, _ 
    ByVal dwProcessId As Long) _ 
As Long 
 
Private Declare Function GetExitCodeProcess _ 
    Lib "kernel32" ( _ 
    ByVal lnghProcess As Long, _ 
    lpExitCode As Long) _ 
As Long 
 
'// If your going to be working with Systems that support security 
'// settings eg NT, XP the access will be checked against any 
'// security descriptor for the target process, so use this Const 
'// Sets all possible access flags for the process object. 
Private Const PROCESS_ALL_ACCESS = &H1F0FFF 
 
'// Define your Paths here! 
'// Note spaces important! 
Private Const ZipExePath As String = "C:\Program files\Winzip\" 
Private Const ZipCom As String = "Winzip32 -min -a " 
'// File types to open & zip 
Private Const strTypeFiles As String = "MS Excel-files (*.xls),*.xls, All files (*.*),*.*" 
Private Const strTitle As String = "Select 1 OR MORE files to Zip & Email" 
 
Public Function ShlProc_IsRunning(ShellReturnValue As Long) As Boolean 
Dim lnghProcess As Long 
Dim lExitCode As Long 
 
'// Get the process handle 
lnghProcess = OpenProcess(PROCESS_ALL_ACCESS, 0&, ShellReturnValue) 
If lnghProcess <> 0 Then 
    '// The GetExitCodeProcess function retrieves the 
    '// termination status of the specified process. 
    GetExitCodeProcess lnghProcess, lExitCode 
    If lExitCode <> 0 Then 
        '// Process still ALIVE! 
        ShlProc_IsRunning = True 
    Else 
        '// YES...finished @ last 
        ShlProc_IsRunning = False 
    End If 
End If 
 
End Function 
 
Sub ShellZipAndEmailIt() 
'// Main routine 
Dim ZipItPID As Long 
Dim strSource As Variant 
Dim strZipFileName As String 
Dim strKillFile As String 
Dim strSourcepath As String 
'// Lets use late binding so User doesn't need to setup ref 
Dim OLook As Object 
Dim Mitem As Object 
Dim OlAttachment As Object 
Dim TmpFolderLocation As String 
Dim i As Integer, Tmp As String 
 
'// Select 1 or more Xl files to Zip 
strSource = Application.GetOpenFilename(strTypeFiles, , strTitle, , True) 
'// Has user cancelled ? 
If TypeName(strSource) = "Boolean" Then End 
 
Dim FsoObj As Object 
Set FsoObj = CreateObject("Scripting.FileSystemObject") 
'// get source path only 
strSourcepath = FsoObj.GetFile(strSource(1)).ParentFolder.Path 
'// get File name only 
strZipFileName = FsoObj.GetFile(strSource(1)).Name & ".zip" 
 
    
'// Get System Tmp Dir 
Dim TmpDir As Object 
Set TmpDir = FsoObj.getSpecialFolder(2) 
TmpFolderLocation = TmpDir.Path & "\" 
 '// Any spaces? Need to have an extra " 
strZipFileName = TmpFolderLocation & strZipFileName 
strKillFile = strZipFileName 
If InStr(1, strZipFileName, " ", vbTextCompare) <> 0 Then 
    strZipFileName = Chr(34) & strZipFileName & Chr(34) 
End If 
   
'// 
'// When you Shell out to an Application the Return Value 
'// is the Applications TaskID 
'// in order to determine if it has Terminated we need to check 
'// if there is an existing process object 
'// the OpenProcess function opens an existing process object. 
'// 
 
'// Shelling out causes an Error Object to be generated so... 
On Error Resume Next 
 
'// Loop & Reset i JIC 
i = 1 
For i = 1 To UBound(strSource) 
    '// spaces! 
    If InStr(1, strSource(i), " ", vbTextCompare) <> 0 Then 
        Tmp = Chr(34) & strSource(i) & Chr(34) 
    Else 
        Tmp = strSource(i) 
    End If 
     
    '// OK now lets Shell out to the Exe file = WinZip32 
    '// winzip[32].exe [-min] action [options] filename[.zip] files 
    '// Any spaces? Need to have an extra " 
    ZipItPID = Shell(ZipExePath & ZipCom & strZipFileName & _ 
        " " & _ 
        Tmp, _ 
        vbNormalFocus) 
 
    '// Check Return Value 
    If ZipItPID = 0 Then MsgBox "NoGo!" & vbCr & "Check your Paths": End 
    'On Error GoTo 0 
 
    '// Ok, lets loop until the App process is terminated! 
    Do While ShlProc_IsRunning(ZipItPID) = True 
        DoEvents 
    Loop 
Next i 
 
On Error GoTo ErrorHandler 
'// Now lets create the Email 
Set OLook = CreateObject("Outlook.Application") 
Set Mitem = OLook.CreateItem(0) 
Set OlAttachment = Mitem.Attachments 
 
'// Add attachment this way to NAME the attachment.... 
'OlAttachment.Add TmpFolderLocation & strZipFileName, _ 
    olByValue, _ 
    1, _ 
    "Updated Excel Workbook" 
 
With Mitem 
    .To = "ivanmoala@xtra.co.nz" 
    .CC = "consult@xcelfiles.com" 
    .BCC = "maymoala@xtra.co.nz" 
    '// Or do it this way... 
    .Attachments.Add strKillFile 
    .Subject = "Updated Budget Workbook" 
    .Body = "Here is the latest update!" 
    .Save 
    '// remove to show 
    '.Display 
    .Send 
End With 
 
ErrorHandler: 
If Err Then 
    MsgBox Err.Number & vbCrLf & _ 
        Err.Description 
Else 
    MsgBox "Zip & Email complete!" & vbCrLf & vbCrLf & _ 
        i - 1 & " workbook(s) have been zipped" 
    Kill strKillFile 
End If 
'// Cleanup 
Set OLook = Nothing 
Set Mitem = Nothing 
Set OlAttachment = Nothing 
Set FsoObj = Nothing 
Set TmpDir = Nothing 
 
End Sub