Public Sub SendEmails()
Dim sBody
Dim vTo, vSubj
Dim vFile, vDir
vDir = Environ("UserProfile") & "\My Documents\"
vFile = vDir & "output.xls"
'================
'send 1 email with everyones address, or
'================
Sheets(3).Activate
Range("D1").Select
While ActiveCell.Value <> ""
vTo = vTo & ActiveCell.Value & ";"
ActiveCell.Offset(1, 0).Select 'next row
Wend
'copy the sheets to new workbook
Sheets(Array("Sheet1", "Sheet2")).Select
Sheets("Sheet2").Activate
Sheets(Array("Sheet1", "Sheet2")).Copy
ActiveWorkbook.SaveAs vFile, , , , , , , xlLocalSessionChanges
ActiveWorkbook.Close
vSubj = "Subject: workbook"
sBody = ""
Send1Email vTo, vSubj, sBody, vFile
End Sub
'-------
'YOU MUST ADD THE OUTLOOK APP IN REFERENCES!!! checkmark OUTLOOK OBJECT LIB in the vbE menu, Tools, References
'-------
Public Function Send1Email(ByVal pvTo, ByVal pvSubj, ByVal pvBody, Optional pvFile) As Boolean
Dim oApp As Outlook.Application
Dim oMail As Outlook.MailItem
On Error GoTo ErrMail
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(olMailItem)
With oMail
.To = pvTo
.Subject = pvSubj
.Body = pvBody
.Attachments.Add pvFile, olByValue, 1
.Send
End With
EmailO = True
Endit:
Set oMail = Nothing
Set oApp = Nothing
Exit Function
ErrMail:
MsgBox Err.Description, vbCritical, Err
Resume Endit
Resume
End Function