Running into error message in title when attempting to link attachments to email. The attachments are stored in Folder Names respective to the "type" of company, which is why I'm attempting to add a for loop to retrieve "type" from spreadsheet.
Sub mailTest()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim olAttachmentLetter As Outlook.Attachments
Dim fileLocationLetter As String
Dim dType As String
For i = 2 To 3
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachmentLetter = olMail.Attachments
fileLocationLetter = "C:\...\user\Desktop\FileLocation"
letterName = "TestLetter1"
dType = Worksheets("Test1").Cells(i, 2).Value
mailBody = "Hello " _
& Worksheets("Test1").Cells(i, 4) _
& "," _
& Worksheets("BODY").Cells(2, 1).Value _
& Worksheets("BODY").Cells(3, 1).Value _
& Worksheets("BODY").Cells(4, 1).Value & " " & dType _
& Worksheets("BODY").Cells(5, 1).Value & " TTT" & dType & "xx18" _
& Worksheets("BODY").Cells(6, 1).Value _
& Worksheets("BODY").Cells(7, 1).Value
With olMail
.To = Worksheets("Test1").Cells(i, 5).Value
.Subject = Worksheets("Test1").Cells(i, 3).Value & " - "
.HTMLBody = "<!DOCTYPE html><html><head><style>"
.HTMLBody = .HTMLBody & "body{font-family: Calibri, ""Times New Roman"", sans-serif; font-size: 13px}"
.HTMLBody = .HTMLBody & "</style></head><body>"
.HTMLBody = .HTMLBody & mailBody & "</body></html>"
''Adding attachment
.Attachments.Add fileLocationLetter & letterName & ".pdf"
.Display
'' .Send (Once ready to send)
End With
Set olMail = Nothing
Set olApp = Nothing
Next
End Sub
What am I doing wrong here? The file is stored in 'C:...\user\Desktop\FileLocation\TestLetter1.pdf'
Thank you kindly.
You are missing the \ between the fileLocation and the letterName. Thus, either write this:
.Attachments.Add fileLocationLetter & "\" & letterName & ".pdf"
or this:
fileLocationLetter = "C:\...\user\Desktop\FileLocation\"
With much help from #Vityata, figured it out.
Essentially being able to make two attachments, one is static with known file name, the second attachment's name is dependent on stored cell value. The workaround was to break the path/name of the file as stored strings. Maybe there's an easier way, but this worked for me!
Code used:
Sub mailTest()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
'' Identify Attachments
Dim olAttachmentLetter As Outlook.Attachments
Dim olAttachmentSSH As Outlook.Attachments
'' Identify Attachment Locations / Paths
Dim fileLocationLetter As String
Dim fileLocationSSH As String
Dim fileLocationSSHi As String
Dim fileLocationSSHii As String
'' Type Variable, referencing cell in worksheet where "Type" is stored (in loop below)
Dim dType As String
'' Creating the loop - Replace 4 with end of rows. Will eventually create code to automatically identify the last cell with stored value
For i = 2 To 4
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
Set olAttachmentLetter = olMail.Attachments
Set olAttachmentSSH = olMail.Attachments
''File Location for Letter
fileLocationLetter = "C:\...\Directory"
''File Location for Excel sheet - Need 3 fields as file name is dynamic based on loop value
fileLocationSSH = "C:\...\Directory\Excel Files"
fileLocationSSHi = "Beginning of File name..."
fileLocationSSHii = " ... End of File name"
letterName = "Name of PDF attachment"
dType = Worksheets("Test1").Cells(i, 2).Value
''Body of Email - Each new line represents new value (linking to hidden worksheet in Excel doc)
mailBody = "Hello " _
& Worksheets("Test1").Cells(i, 4) _
& "," _
& Worksheets("BODY").Cells(2, 1).Value _
& Worksheets("BODY").Cells(3, 1).Value _
& Worksheets("BODY").Cells(4, 1).Value & " " & dType _
& Worksheets("BODY").Cells(5, 1).Value _
& Worksheets("BODY").Cells(6, 1).Value _
& Worksheets("BODY").Cells(7, 1).Value
With olMail
.To = Worksheets("Test1").Cells(i, 5).Value
.Subject = Worksheets("Test1").Cells(i, 3).Value
.HTMLBody = "<!DOCTYPE html><html><head><style>"
.HTMLBody = .HTMLBody & "body{font-family: Calibri, ""Times New Roman"", sans-serif; font-size: 13px}"
.HTMLBody = .HTMLBody & "</style></head><body>"
.HTMLBody = .HTMLBody & mailBody & "</body></html>"
'' Adding attachments, referencing file locations and amending file name if needed
.Attachments.Add fileLocationLetter & "\" & letterName & ".pdf"
.Attachments.Add fileLocationSSH & "\" & dType & "\" & fileLocationSSHi & dType & fileLocationSSHii & ".xlsx"
.Display
'' .Send (Once ready to send)
End With
Set olMail = Nothing
Set olApp = Nothing
Next
End Sub
Related
I am trying to add a document to an email as a PDF. I am trying to change the file name to include the date which is stored in a table in the Word document.
I can create the email but the script gives me an error when it tries to export.
How can I attach the file as a PDF with a file name with the date pulled from the table in Word?
Sub CommandButton1_Click()
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Dim DateField As String
Dim desktoploc As String
Dim mypath As String
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
Doc.Save
'Pull date from table and change format
DateField = Format(Doc.Content.Tables(1).Cell(1, 4).Range.Text, "yyyymmdd")
'Pull line number and subject names from table 1 and table 2 in word to add to subject.
Dim linenum As Word.Range, subject1 As Word.Range, subjec2 As Word.Range
'Need to remove hidden line breaks from tables in word in order to fit on subject line of email
Set linenum = Doc.Content.Tables(1).Cell(1, 2).Range
linenum.MoveEnd unit:=wdCharacter, Count:=-1
Set subject1 = Doc.Content.Tables(2).Cell(2, 1).Range
subject1.MoveEnd unit:=wdCharacter, Count:=-1
Set subjec2 = Doc.Content.Tables(2).Cell(3, 1).Range
subjec2.MoveEnd unit:=wdCharacter, Count:=-1
'Create PDF File
Dim file_name As String
Dim NewFileName As String
NewFileName = "Load Limits Subjects " & linenum & " " & DateField
file_name = ActiveDocument.Path & "\" & Left(ActiveDocument.Name, InStrRev(ActiveDocument.Name, ".") - 1) & NewFileName & ".pdf"
'This is where I keep getting the error.....
ActiveDocument.ExportAsFixedFormat OutputFileName:=file_name, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, Item:= _
wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
With EmailItem
.Display
.Subject = "Limit Notification - Subject " & linenum & " #line #" & linenum & _
" #" & subject1.Text & " #" & subjec2.Text & vbCrLf
.Body = "Please see the attached Limit Notification for Subject " & linenum.Text & vbCrLf & _
"" & vbCrLf & _
"Let me know if you have any questions." & vbCrLf & _
"" & vbCrLf & _
"Thank you," & vbCrLf & vbCrLf & _
"INSERT SIGNATURE HERE"
'Update Recipient List here:
.To = "LineEmail#email.com; "
.CC = "Another Email#demail.com"
'.Importance = olImportanceNormal
.Attachments.Add Doc.FullName
End With
End Sub
Your code has multiple flaws, including:
Your DateField string is trying to convert something that includes a table cell's end-of-cell marker into an ISO-format date
Your code is not validating the NewFileName string as a filename.
Your code is trying to to attach the document to the email, not the pdf.
Your code is referencing ActiveDocument (which may no longer be the same as Doc) when creating path etc. for the new filename.
Try something along the lines of:
Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Dim Rng As Range
Dim i As Long
Dim NewFileName As String
Dim MailSubject As String
Dim MailBody As String
Const StrNoChr As String = """*./\:?|"
NewFileName = " Load Limits Subjects "
MailSubject = "Limit Notification - Subject "
MailBody = "Please see the attached Limit Notification for Subject "
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
With Doc
.Save
Set Rng = .Tables(1).Cell(1, 2).Range
Rng.End = Rng.End - 1
NewFileName = NewFileName & Rng.Text & " "
MailSubject = MailSubject & Rng.Text & " #line #" & Rng.Text & " #"
MailBody = MailBody & Rng.Text
Set Rng = .Tables(1).Cell(1, 4).Range
Rng.End = Rng.End - 1
NewFileName = NewFileName & Format(Rng.Text, "YYYYMMDD")
Set Rng = .Tables(2).Cell(2, 1).Range
Rng.End = Rng.End - 1
MailSubject = MailSubject & Rng.Text
Set Rng = .Tables(2).Cell(3, 1).Range
Rng.End = Rng.End - 1
MailSubject = MailSubject & Rng.Text
For i = 1 To Len(StrNoChr)
NewFileName = Replace(NewFileName, Mid(StrNoChr, i, 1), "_")
Next
NewFileName = Split(.FullName, ".doc")(0) & NewFileName & ".pdf"
SaveAs2 FileName:=NewFileName, FileFormat:=wdFormatPDF, AddToRecentFiles:=False
End With
MailBody = MailBody & vbCrLf & _
"" & vbCrLf & _
"Let me know if you have any questions." & vbCrLf & _
"" & vbCrLf & _
"Thank you," & vbCrLf & vbCrLf & _
"INSERT SIGNATURE HERE"
With EmailItem
.Display
.Subject = MailSubject
.Body = MailBody
'Update Recipient List here:
.To = "LineEmail#email.com; "
.CC = "Another Email#demail.com"
'.Importance = olImportanceNormal
.Attachments.Add NewFileName
End With
End Sub
For i = LBound(reviewer_names) To UBound(reviewer_names)
reviwer_strg = reviewer_names(i)
assigned_to_strg = assigned_to_names(LBound(assigned_to_names))
For j = 6 To 15
st1 = ThisWorkbook.Sheets("Master").Range("H" & j).Value
If (reviwer_strg = st1) Then
reviewer_email_id = ThisWorkbook.Sheets("Master").Range("I" & j).Value
Set olMail = olApp.CreateItem(olMailItem)
olMail.To = reviewer_email_id
olMail.Recipients.Add (reviewer_email_id)
olMail.Subject = "Task for Review;" & client_name & ";" & title
str1 = "Dear " & reviewer & ", " & "<br>" & "Please see the following for review." & "<br>"
str2 = "Task : " & title & "<br>" & "Client Name : " & client_name & "<br>" & "Due Date : " & due_date & "<br><br>"
str3 = "Document Location : " & "" & document_location & "" & "<br>"
str4 = "Backup Location : " & "" & backup_location & "" & "<br><br>"
str5 = "Awaiting your Feedback." & "<br>" & "Regards, " & "<br>" & assigned_to_strg
olMail.HTMLBody = "<BODY style=font-size:10pt;font-family:Verdana>" & str1 & str2 & str3 & str4 & str5 & "</BODY>"
olMail.Send
End If
Next
Next i
I am sending emails by extracting email-ids from a column in excel, by comparing the names entered in a cell.
Cells from where I am extracting the names.
"Assigned to" and "Reviewer" Columns which is used to compare the names entered in the cells and the names in the columns. from this I am picking up the corresponding email id and sending mail.
The emails that I am sending are through loops. Hence everytime a mail is sent, the olMail.To picks up a single email id, and sends email to all the reviewers it matches in the column. But the recipients shows only the email id of the current recipient. I want to show all the email ids to which the email is sent, but send emails to each reviewer. ( Like mail to multiple addresses). The problem is that if I add all the email ids that are matched, in olMail.To, it gives me an error since it cannot contain more than one email id at a time.
How to do it?
It's a good idea to review the documentation for any procedures you're using with which you aren't completely familiar.
The To property returns or sets a semicolon-delimited String list of display names for the To recipients for the Outlook item. This property contains the display names only. The To property corresponds to the MAPI property PidTagDisplayTo. The Recipients collection should be used to modify this property.
(Source)
The Recipients collection contains a collection of Recipient objects for an Outlook item. Use the Add method to create a new Recipient object and add it to the Recipients object.
(Source)
Example:
ToAddress = "test#test.com"
ToAddress1 = "test1#test.com"
ToAddress2 = "test#test.com"
MessageSubject = "It works!."
Set ol = CreateObject("Outlook.Application")
Set newMail = ol.CreateItem(olMailItem)
newMail.Subject = MessageSubject
newMail.RecipIents.Add(ToAddress)
newMail.RecipIents.Add(ToAddress1)
newMail.RecipIents.Add(ToAddress2)
newMail.Send
(Source)
This is the solution code in case someone needs it :
For i = LBound(reviewer_names) To UBound(reviewer_names) - 1
reviwer_strg = reviewer_names(i)
assigned_to_strg = assigned_to_names(LBound(assigned_to_names))
For j = 6 To 15
st1 = ThisWorkbook.Sheets("Master").Range("H" & j).Value
If (reviwer_strg = st1) Then
reviewer_email_id = ThisWorkbook.Sheets("Master").Range("I" & j).Value
Set olMail = olApp.CreateItem(olMailItem)
olMail.Subject = "Task for Review;" & client_name & ";" & title
str1 = "Dear " & reviewer & ", " & "<br>" & "Please see the following for review." & "<br>"
str2 = "Task : " & title & "<br>" & "Client Name : " & client_name & "<br>" & "Due Date : " & due_date & "<br><br>"
str3 = "Document Location : " & "" & document_location & "" & "<br>"
str4 = "Backup Location : " & "" & backup_location & "" & "<br><br>"
str5 = "Awaiting your Feedback." & "<br>" & "Regards, " & "<br>" & assigned_to_strg
olMail.HTMLBody = "<BODY style=font-size:10pt;font-family:Verdana>" & str1 & str2 & str3 & str4 & str5 & "</BODY>"
For x = LBound(reviewer_names) To UBound(reviewer_names)
recipient_strg = reviewer_names(x)
Debug.Print x & reviewer_names(x)
For y = 6 To 15
st2 = ThisWorkbook.Sheets("Master").Range("H" & y).Value
If (recipient_strg = st2) Then
recipient_email_id = ThisWorkbook.Sheets("Master").Range("I" & y).Value
olMail.Recipients.Add (recipient_email_id)
End If
Next y
Next x
olMail.Send
End If
Next
Next i
MsgBox ("Email has been sent !!!")
End If
Please look at the example below. I think this will do all you want, and more.
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
See the link below for more details.
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
I have code which sends a file via Outlook and gets-saves data into an Excel file.
For sending a file via Outlook, it works perfectly. However it saves data into the same row of the Excel file. Code should save data into the next empty row of the Excel file.
Sub AutoEmail()
On Error GoTo Cancel
Dim Resp As Integer
Resp = MsgBox(prompt:=vbCr & "Yes = Review Email" & vbCr & "No = Immediately Send" & vbCr & "Cancel = Cancel" & vbCr, _
Title:="Review email before sending?", _
Buttons:=3 + 32)
'dfsfsd
Range("S20").Copy
Range("T20").PasteSpecial xlPasteValues
'sdaasdf
Workbooks.Open ("C:\Users\computername\Desktop\New folder (2)\ff.xlsx")
ThisWorkbook.Activate
'1
Workbooks("1435250.xlsx").Worksheets("RFI").Range("T20").Copy _
Workbooks("ff.xlsx").Worksheets("Sayfa1").Range("P2")
'1
Select Case Resp
'Yes was clicked, user wants to review email first
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = Application.ActiveWorkbook.FullName
With otlNewMail
.To = Cells(33, 10)
.CC = Cells(1, 1)
.Subject = Cells(23, 10) & ": " & Cells(21, 10)
.Body = "this is a text" & vbCr & vbCr & "" & Cells(23, 10) & "."
.Attachments.Add FName
.Display
End With
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If no is clicked
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & " " & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Send
'.Display
'Application.Wait (Now + TimeValue("0:00:01"))
'Application.SendKeys "%s"
End With
'otlApp.Quit
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If Cancel is clicked
Case Is = 2
Cancel:
MsgBox prompt:="No Email has been sent.", _
Title:="EMAIL CANCELLED", _
Buttons:=64
End Select
End Sub
How can I save data (End(xlUp).Row) into the next empty row of an Excel file?
Change:
Workbooks("1435250.xlsx").Worksheets("RFI").Range("T20").Copy _
Workbooks("ff.xlsx").Worksheets("Sayfa1").Range("P2")
To this:
With Workbooks("ff.xlsx").Worksheets("Sayfa1")
Workbooks("1435250.xlsx").Worksheets("RFI").Range("T20").Copy .Range("P" & .Range("P" & .Rows.count).End(xlUp).Row + 1)
End With
I have this code to send e-mail with attached via Outlook:
Sub AutoEmail()
On Error GoTo Cancel
Dim Resp As Integer
Resp = MsgBox(prompt:=vbCr & "Yes = Review Email" & vbCr & "No = Immediately Send" & vbCr & "Cancel = Cancel" & vbCr, _
Title:="Review email before sending?", _
Buttons:=3 + 32)
Select Case Resp
'Yes was clicked, user wants to review email first
Case Is = 6
Dim myOutlook As Object
Dim myMailItem As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = Application.ActiveWorkbook.FullName
With otlNewMail
.To = Cells(33, 10)
.CC = Cells(1, 1)
.Subject = Cells(23, 10) & ": " & Cells(21, 10)
.Body = "Good morning" & vbCr & vbCr & "" & Cells(23, 10) & "."
.Attachments.Add FName
.Display
End With
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If no is clicked
Case Is = 7
Dim myOutlok As Object
Dim myMailItm As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = ""
.CC = ""
.Subject = ""
.Body = "Good Morning," & vbCr & vbCr & " " & Format(Date, "MM/DD") & "."
.Attachments.Add FName
.Send
'.Display
'Application.Wait (Now + TimeValue("0:00:01"))
'Application.SendKeys "%s"
End With
'otlApp.Quit
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
'If Cancel is clicked
Case Is = 2
Cancel:
MsgBox prompt:="No Email has been sent.", _
Title:="EMAIL CANCELLED", _
Buttons:=64
End Select
End Sub
However there is another thing that i want to add. I want to write some cells into another excel after sending e-mail via Outlook, lets say A2 to B15. The excel file which i want to write on is in C:\Users\Computername\Desktop\Savingdata.xlsx
Mert,
Try the following, add these two lines at the beginning of your code:
Dim wbThisWorkbook, wbTheOneToSaveTo As Workbook
Set wbThisWorkbook = Workbooks("TheNameOfYourCurrentWorkbook")
Then after your sending routine, add this:
Set wbTheOneToSaveTo = Workbooks.Open ("C:\Users\Computername\Desktop\Savingdata.xlsx")
wbThisWorkbook.Sheets("TheNameOfThe Worksheet").Range("A2").Copy
wbTheOneToSaveTo.Sheets("TheNameOfTheWorksheet").Range("B15").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'adjust parameters according to your needs
wbTheOneToSaveTo.Close True
wbThisWorkbook.Activate
Hope this helps!
When I complete a piece of work I email it to certain people. It depends on the work who gets it.
If any person in the list leaves, changes job or has an email change the code will bug out saying
Run Time error -2147467259(80004005), Outlook Does Not Recognise One Or More Names
If I manually copy the email addresses in the list and pop them into Outlook and send I'll get an email back saying the user doesn't exist or has been changed.
I have tried On Error Resume Next and On Error Goto. I have added MS Outlook 14.0 Object Libary, SharePoint Social Provider, Social Provider Extensibility and Outlook View control from the references.
The code bugs out on the .send
Sub EMailer()
Application.ScreenUpdating = False
strfilepath = "\\DFZ70069\Data\199711009\workgroup\Res Plan Team\Performance Management\Specialised Reporting\Debit & Credit Reporting\Masters\Sent Reports\"
strArea = "Recipients" '..........................................................................................
'Get list of recipients for email
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value = "" Then GoTo Continue
strmaillist = strmaillist & cell.Value + ";"
Continue:
Next
[B1].Value = strmaillist
If bMyEmail = True Then
strmaillist = strmaillist & MyEmailAddress
End If
'Display email list
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Sending " & sReportName & " emails to " & vbNewLine & strArea, _
AckTime, "Message Box", 0)
Case 1, -1
End Select
'SEND EMAIL
'set up Body of email............
strbody = "Please find attached " & sReportName & " Report " & " _" & strDate & vbLf & vbLf & _
strComments & vbLf & _
strComments2 & vbLf & _
"" & vbLf & _
eMailName & vbLf & _
"MI & Performance Reporting Team" & vbLf & _
sline2 & vbLf & _
sline3 & vbLf & vbLf & _
sLine4
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = strmaillist
.CC = ""
.BCC = ""
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
.send ' bugs out here
End With
Set OutMail = Nothing
Set OutApp = Nothing
ThisWorkbook.Activate
Sheets("Sheet1").Select
Application.ScreenUpdating = True: Application.ScreenUpdating = False
Sheets("Sheet1").Select
Range(sRange2).Value = sConclusion '.
Application.ScreenUpdating = True: Application.ScreenUpdating = False
End Sub
You can try to check the validity of the recipient before sending, by using the .Resolve method of the Recipient object. Only valid recipients can be kept in the Recipient list of the mail item.
You might try this:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = sReportName & " Report " & strDate
.HTMLBody = "Set to HTML" & vbLf & vbLf & ""
.Body = strbody
.Attachments.Add (strfilepath & sTemplateName)
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value <> "" Then
set r = .Recipients.Add(cell.value)
If Not r.Resolve then r.Delete '<~~ Removes invalid recipients
End If
Next
.send
End With