Send worksheet as an attachment to specified recipients via outlook

Hi All,

I've got some codes form http://www.ozgrid.com/VBA/send-email.htm

Below Codes work fine, but just for one recipient and without any message body.

Sub SendActiveWorkbook()

    ActiveWorkbook.SendMail _
    Recipients:="1is2@gmaaal.com", _
    Subject:="Try Me " & Format(Date, "dd/mmm/yy")

End Sub

Here I would like to get the options to add more Recipients with the message body.

For Example:
To:1is2@gmaaal.com
CC:1is3@gmaaal.com;1is4@gmaaal.com;2is20@hotttmail.com
Subject: Data Updated on "System Time"
Message Body: This is a system generated mail. Please do not reply.

I tried with below codes for adding more recipients, but did not get the above desired solution.

Sub Send1Sheet_ActiveWorkbook()
'
' To send any specified Excel Worksheet as an attachment to specified recipients
'Create a new Workbook Containing 1 Sheet (left most) _
 and sends as attachment.

    ThisWorkbook.Sheets(1).Copy

    With ActiveWorkbook
        Range("A1").Value = VBA.Date
         Range("A2").Value = VBA.Time
         
         .SendMail Recipients:=Array("1is2@gmaaal.com", _
                         "2is20@hotttmail.com"), _
          Subject:="Hello! " & Format(Date, "dd/mmm/yy")
         .Close SaveChanges:=False

    End With

End Sub

I hope you guys make it easy for me, Thanks in advance!

hi,
try this one and see if it helps you!

Thanks for ur replying, I just changed the file path name in the module, like:
MyFile = "C:\My Documents\Send worksheet as an attachment.xlsm"

But nothing is working fine, before I was getting File Not Found msg, and now getthing a run-time error '70'" Permission Denied.

Private Sub CommandButton1_Click()
sendemail
End Sub
Public Function sendemail()
'switch off screen updating to speed up code and prevent screen flickering
        Application.ScreenUpdating = False

If MsgBox("Do You want to send it now?", vbYesNoCancel + vbQuestion) = vbYes Then

Dim WorkbookToSend As Workbook
On Error GoTo ende
esubject = "Hello! " & Format(Date, "dd/mmm/yy")

sendto = ""
ccto = ""
ebody = "Please find part of daily xxx attached." & vbCrLf & "yyyy" & vbCrLf & vbCrLf & "best regards" & vbCrLf & ""
Workbooks.Add
Set WorkbookToSend = ActiveWorkbook
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Cells.Copy Destination:=WorkbookToSend.Sheets(1).Cells
WorkbookToSend.SaveAs "C:\My Documents\Send worksheet as an attachment.xlsm"
WorkbookToSend.Close

newfilename = "C:\My Documents\Send worksheet as an attachment.xlsm"
Set app = CreateObject("Outlook.Application")
Set itm = app.createitem(0)

With itm
.Subject = esubject
.To = sendto
.cc = ccto
.body = ebody
.attachments.Add (newfilename)
.display
End With
        'With Sheet1
       '.Cells(.Rows.Count, 11).End(xlUp).Offset(, 1).Value = "e-mail sent " & Now
        'End With


Set app = Nothing
Set itm = Nothing

ende:
 Dim MyFile As String    'This line of code is optional
    On Error Resume Next  'On hitting errors, code resumes next code
    MyFile = "C:\My Documents\Send worksheet as an attachment.xlsm"
    Kill MyFile
    
    Else
     ' Do nothing
End If
Application.ScreenUpdating = True
End Function

hi,
the code saves the file in a new location,

'
WorkbookToSend.SaveAs "C:\users\sunoffice\desktop\sunoffice.xlsm"   'sunoffice is yr file
'

sends it and then

Dim MyFile As String    'This line of code is optional
    On Error Resume Next  'On hitting errors, code resumes next code
    MyFile = "C:\users\sunoffice\desktop\sunoffice.xlsm"
    Kill MyFile

it kills it! don't worry about it!
pls follow the steps:
use the email file, you want to send sheet1.
right click any file from yr desktop, click Properties and see "Location", copy it, then go to code and add the Location and file name you want to be sent.
(i.e "C:\users\sunoffice\desktop\sunoffice.xlsm"), sunoffice.xlsm is the new name of yr file
check the inbox and see what you rcvd!

John, now ur codes working fine, plz see below; but sends the entire workbook instead of just one sheet and makes a backup copy of the workbook. If I run the codes for the next time then it asks me to replace the the existing workbook - test1. Kindly improve the cycle.

Private Sub CommandButton1_Click()
sendemail
End Sub

Public Function sendemail()
' solution by john55
'switch off screen updating to speed up code and prevent screen flickering
        
        Application.ScreenUpdating = False

If MsgBox("Do You want to send it now?", vbYesNoCancel + vbQuestion) = vbYes Then

Dim WorkbookToSend As Workbook
On Error GoTo ende
esubject = "Hello! " & Format(Date, "dd/mmm/yy")

sendto = "emailadd1@gmail.com"
ccto = "emailadd2@hotmail.com; emailadd3@hotmail.com"
ebody = "Please find part of daily xxx attached." & vbCrLf & "yyyy" & vbCrLf & vbCrLf & "best regards" & vbCrLf & ""
Workbooks.Add
Set WorkbookToSend = ActiveWorkbook
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Cells.Copy Destination:=WorkbookToSend.Sheets(1).Cells
WorkbookToSend.SaveAs "C:\Documents and Settings\My Documents\test1.xls"
WorkbookToSend.Close

newfilename = "C:\Documents and Settings\My Documents\test1.xls"
Set app = CreateObject("Outlook.Application")
Set itm = app.createitem(0)

With itm
.Subject = esubject
.To = sendto
.cc = ccto
.body = ebody
.attachments.Add (newfilename)
.display
End With
        'With Sheet1
       '.Cells(.Rows.Count, 11).End(xlUp).Offset(, 1).Value = "e-mail sent " & Now
        'End With


Set app = Nothing
Set itm = Nothing

ende:
 Dim MyFile As String    'This line of code is optional
    On Error Resume Next  'On hitting errors, code resumes next code
    MyFile = "C:\Documents and Settings\My Documents\Email Sheet.xls"
    Kill MyFile
    
    Else
     ' Do nothing
End If
Application.ScreenUpdating = True
End Function

hi sunoffice,
so, you are in email file and want to send sheet1.
in code, give a name to your file, let's say test1.xls
so your path will be:

WorkbookToSend.SaveAs "C:\Documents and Settings\Desktop\test1.xls"

test1.xls if you want to be xls or .xlsm with macro.

Plz also look the smallest codes & link in my 1st post of this thread.

HI,

I modified the Function code and test here. I did not receive any errors.

Public Function sendemail()
'switch off screen updating to speed up code and prevent screen flickering
        Application.ScreenUpdating = False

If MsgBox("Do You want to send it now?", vbYesNoCancel + vbQuestion) = vbYes Then

Dim WorkbookToSend As Workbook
On Error GoTo ende
esubject = "Hello! " & Format(Date, "dd/mmm/yy")

sendto = ""
ccto = ""
ebody = "Please find part of daily xxx attached." & vbCrLf & "yyyy" & vbCrLf & vbCrLf & "best regards" & vbCrLf & ""
Workbooks.Add
ThisWorkbook.Sheets(1).Cells.Copy Destination:=ActiveWorkbook.Sheets(1).Cells

ActiveWorkbook.SaveAs Filename:="C:\Desktop\xxx.xls"
ActiveWorkbook.Close

newfilename = "C:\Desktop\xxx.xls"
Set app = CreateObject("Outlook.Application")
Set itm = app.createitem(0)

With itm
.Subject = esubject
.To = sendto
.cc = ccto
.body = ebody
.attachments.Add (newfilename)
.display
End With
Set app = Nothing
Set itm = Nothing

ende:
 Dim MyFile As String    'This line of code is optional
    On Error Resume Next  'On hitting errors, code resumes next code
    MyFile = "C:\Desktop\xxx.xls"
    Kill MyFile
    
    Else
     ' Do nothing
End If
Application.ScreenUpdating = True
End Function

Charles now I just edited the path..., and it's working fine.

ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\My Documents\test1.xls"
ActiveWorkbook.Close

newfilename = "C:\Documents and Settings\My Documents\test1.xls"
Set app = CreateObject("Outlook.Application")
Set itm = app.createitem(0)

ende:
 Dim MyFile As String    'This line of code is optional
    On Error Resume Next  'On hitting errors, code resumes next code
    MyFile = "C:\Documents and Settings\My Documents\Email Sheet.xls"
    Kill MyFile

...but It sends the entire workbook instead of a single sheet (sheet1), and makes a backup file (workbook)as test1 in the folder directory (which is not useful for me). The codes run successfully and makes ready the email to send, but I want to sent it automatically, and this process should like be in invisible mode so the sender has not to click on the send mail button. I hope u can understand & help me.

Sir, Have u notice about the codes, which I mentioned in my 1st post of this thread.

hi sunoffice,
it sends just sheet1, try to write something in yr sheet2 and then check in yr emai rcvd.
and if you wanna send it without preview just modify:

With itm
.Subject = esubject
.To = sendto
.cc = ccto
.body = ebody
.attachments.Add (newfilename)
'.display
.send

and pay attention at this:

ActiveWorkbook.SaveAs Filename:="C:\Documents and Settings\My Documents\test1.xls"
ActiveWorkbook.Close

newfilename = "C:\Documents and Settings\My Documents\test1.xls"
Set app = CreateObject("Outlook.Application")
Set itm = app.createitem(0)
'
'
ende:
 Dim MyFile As String    'This line of code is optional
    On Error Resume Next  'On hitting errors, code resumes next code
    MyFile = "C:\Documents and Settings\My Documents\test1.xls"
    Kill MyFile
'

you should have the same file!!
hope it helps you!

John,
Just done these above changes, and it's amazing man! It's directly come into my inbox and without any useless backup copy in the folder drive

I wrote in the sheet2 & sheet3, but I see the received attached via mail just has data on the sheet1 and the other sheets are blank.
So can I hope this will not send any vba codes to the recipients, just forward the data on the sheet1??

hi SunOffice,
as far as i know it sends just data! please run some tests!

Thanks mate!! Yeah It's working fine....!!

...and I've seen some short codes, plz see below:

' http://boisgontierjacques.free.fr/pa...te/outlook.htm

Sub envoi_Feuille()
répertoireAppli = ActiveWorkbook.Path ' Penser à Outils/Références Outlook
Sheets("résultats").Copy ' crée un classeur avec la feuille résultats
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs répertoireAppli & "\Resultats.xls"
ActiveWindow.Close
'--- Envoi par mail
Dim olapp As Outlook.Application
Sheets("destinataires").Select
Range("A11").Select
Do While Not IsEmpty(ActiveCell)
Dim msg As MailItem
Set olapp = New Outlook.Application
Set msg = olapp.CreateItem(olMailItem)
msg.To = ActiveCell.Value
msg.Subject = Range("A2").Value
msg.Body = Range("A5").Value & Chr(13) & Chr(13) & Range("A8").Value & Chr(13) & Chr(13)
msg.Attachments.Add Source:=répertoireAppli & "\Resultats.xls"
msg.Send
ActiveCell.Offset(1, 0).Select
Loop
End Sub

can you/ anyone plz translate it into English?

...and below codes are fine as the above.

Sub EmailSheet()
''To email your worksheet1 by the following code.

Worksheets("Sheet1").Copy
ActiveWorkbook.SendMail Recipients:="sample@gmail.com"
ActiveWorkbook.Close False
End Sub