Winzip and email multiple files (RondeBriuins code not working)
 

The problem is with defining the path ("'// Define your Paths here!"

Thanks


'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
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
'// Define your Paths here!
Dim strSource As Path
strSource = "N:\mis\moi Reporting\082008\UKA Reports\CARC-GE3" ' & " "
& "N:\mis\moi\moiReporting\082008\UKA Reports\CARC-lt3.xls" & " " & "N:
\mis\moi\AudaSource Reporting\082008\UKA Reports\UKA-GE3.xls" & " " &
"N:\mis\moi\moiReporting\082008\UKA Reports\UKA-lt3.xls")

'// 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(CARCGE3, 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

'// 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

'Shell out to the Exe file = WinZip32
' winzip[32].exe [-min] action [options] filename[.zip] files
ZipItPID = Shell(ZipExePath & ZipCom & strZipFileName & _
" " & _
Tmp, _
vbNormalFocus)

'// Check Return Value
If ZipItPID = 0 Then MsgBox "NoGo!" & vbCr & "Check file 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 as it NAMES the attachment....
'OlAttachment.Add TmpFolderLocation & strZipFileName, _
olByValue, _
1, _
"Updated Excel Workbook"

With Mitem
.To = "
'.CC = ""
'.BCC = ""
'// Or
'.Attachments.Add strKillFile
'.Subject = ""
'.Body = ""
'.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

Winzip and email multiple files (RondeBriuins code not working)
 

This is not my code

--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Simon" wrote in message ...
The problem is with defining the path ("'// Define your Paths here!"

Thanks


'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
Private Const PROCESS_ALL_ACCESS = &H1F0FFF
'// Define your Paths here!
Dim strSource As Path
strSource = "N:\mis\moi Reporting\082008\UKA Reports\CARC-GE3" ' & " "
& "N:\mis\moi\moiReporting\082008\UKA Reports\CARC-lt3.xls" & " " & "N:
\mis\moi\AudaSource Reporting\082008\UKA Reports\UKA-GE3.xls" & " " &
"N:\mis\moi\moiReporting\082008\UKA Reports\UKA-lt3.xls")

'// 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(CARCGE3, 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

'// 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

'Shell out to the Exe file = WinZip32
' winzip[32].exe [-min] action [options] filename[.zip] files
ZipItPID = Shell(ZipExePath & ZipCom & strZipFileName & _
" " & _
Tmp, _
vbNormalFocus)

'// Check Return Value
If ZipItPID = 0 Then MsgBox "NoGo!" & vbCr & "Check file 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 as it NAMES the attachment....
'OlAttachment.Add TmpFolderLocation & strZipFileName, _
olByValue, _
1, _
"Updated Excel Workbook"

With Mitem
.To = "
'.CC = ""
'.BCC = ""
'// Or
'.Attachments.Add strKillFile
'.Subject = ""
'.Body = ""
'.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