PDA

View Full Version : Solved: send active worksheet to outlook mail recipient as an attachment



rajagopal
08-08-2008, 02:16 AM
#1 - when the user close an excel file, the user will get a pop-up "Have you updated the details of A,B,C" using worksheet_beforeclose function.
If you user select Yes, then "thank you" message will be displayed.

#2 - When user click "OK" in the Thank you info, the current worksheet has to be sent to outlook mail recipient as an attachment.
To: abc@xyz.com and CC: def@xyz.com
subject: XXXXX and Message body: "Hi......"

I want the code for the action #2. I attached the excel sheet having the code.
Please help me...

Thanks.

Bob Phillips
08-08-2008, 04:01 AM
Public Sub CreateMail()
Dim mpOL As Object
Dim mpTemp As Workbook
Dim mpTempFilepath As String
Dim mpTempFilename As String
Dim mpFileExt As String
Dim mpFileFormat As Long

On Error GoTo CreateMail_Error

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

mpTempFilepath = Environ$("temp") & Application.PathSeparator
mpTempFilename = ActiveSheet.Name & " " & Format(Now, "yyyy-mm-dd hh-mm-ss")
ActiveSheet.Copy
Set mpTemp = ActiveWorkbook
If Val(Application.Version) < 12 Then

mpFileExt = ".xls"
mpFileFormat = -4143
Else

mpFileExt = ".xlsx"
mpFileFormat = 51
End If
mpTemp.SaveAs mpTempFilepath & mpTempFilename & mpFileExt, FileFormat:=mpFileFormat

Set mpOL = GetOutlookApp
If Not mpOL Is Nothing Then

Call CreateMailMessage(mpOL, mpTemp)
End If

CreateMail_Exit:
On Error Resume Next
mpTemp.Close SaveChanges:=False
Kill mpTempFilepath & mpTempFilename & mpFileExt
Set mpOL = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Exit Sub

CreateMail_Error:
Resume CreateMail_Exit
End Sub

Private Function GetOutlookApp() As Object
Dim mpOL As Object
On Error Resume Next
Set mpOL = GetObject(, "Outlook.Application")
If mpOL Is Nothing Then

Set mpOL = CreateObject("Outlook.Application")
End If
Set GetOutlookApp = mpOL
End Function

Private Function CreateMailMessage(ByRef OL As Object, _
ByRef TotalsWb As Workbook)
Dim mpMail As Object

OL.Session.Logon
Set mpMail = OL.CreateItem(0)

On Error Resume Next
With mpMail
.To = "abc@xyz.com"
.CC = "def@xyz.com"
.BCC = ""
.Subject = "XXXX"
.body = "Hi ..."
.Attachments.Add TotalsWb.FullName

OL.Visible = True
.Display
End With

Set mpMail = Nothing
End Function