Option Explicit
Sub EmailandSaveCellValue()
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String, MailSub As String, MailTxt As String
Const MailTo = "some1@someone.com"
Const MailCC = "some2@someone.com"
Const MailBCC = "some3@someone.com"
MailSub = "Please review " & Range("Subject")
MailTxt = "I have attached " & Range("Subject")
Application.ScreenUpdating = False
ActiveSheet.Copy
Set WB = ActiveWorkbook
FileName = Range("Subject") & " Text.xls"
On Error Resume Next
Kill "C:\" & FileName
On Error Goto 0
WB.SaveAs FileName:="C:\" & FileName
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
With oMail
.To = MailTo
.Cc = MailCC
.Bcc = MailBCC
.Subject = MailSub
.Body = MailTxt
.Attachments.Add WB.FullName
.Display
End With
WB.ChangeFileAccess Mode:=xlReadOnly
Kill WB.FullName
WB.Close SaveChanges:=False
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub
|