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
Related
I am trying to use the if then statement inside the .body of my email, but when ever I run it, it does nothing. Below where I noted the body of the email starts is where I am stuck.
Sub Email_From_Excel_Basic()
' This identifies what means what
Dim emailApplication As Object
Dim emailItem As Object
Dim mymsg As String
Dim cell As Range
Application.ScreenUpdating = False
Set emailApplication = CreateObject("Outlook.Application")
' Now we build the email.
On Error GoTo cleanup
For Each cell In Worksheets("owvr").Columns("S").Cells
Set emailItem = emailApplication.CreateItem(0)
If cell.Value Like "?*#?*.?*" And _
Cells(cell.Row, "T") = "Yes" Then
With emailItem
' This is who the email is being sent to
.To = Cells(cell.Row, "S").Value
.CC = Cells(cell.Row, "S").Value
' This is the subject of the email
.Subject = "Status update"
' This is the body of the email based on cell references
mymsg = "Dear " & Cells(cell.Row, "A").Value & " team," & vbNewLine & vbNewLine
Here
mymsg = mymsg & "Status: " & If Cell("D").Value = "1. New Order" Then
mymsg "Your order has been received and will processed."
ElseIf cell("D").Value= "2. Shipped" Then
mymsg = mymsg & "Status: Your order has been shipped" & vbNewLine
Else
End If
mymsg = mymsg & "Deposit invoice: " & Cells(cell.Row, "K").Value & vbNewLine
mymsg = mymsg & "Additional invoice: " & Cells(cell.Row, "M").Value & vbNewLine
.Body = mymsg
.Send
' This part brings the loop back up to the top, so this way it goes to the next email in the column
End With
On Error GoTo 0
Set emailItem = Nothing
End If
Next cell
cleanup:
Set emailApplication = Nothing
Set emailItem = Nothing
Set mymsg = Nothing
Application.ScreenUpdating = True
End Sub
Advice?
Have the IF populate a variable string then concatenate that into the body.
Sub Email_From_Excel_Basic()
' This identifies what means what
Dim emailApplication As Object
Dim emailItem As Object
Dim mymsg As String
Dim cell As Range
Application.ScreenUpdating = False
Set emailApplication = CreateObject("Outlook.Application")
' Now we build the email.
On Error GoTo cleanup
For Each cell In Worksheets("owvr").Columns("S").Cells
Set emailItem = emailApplication.CreateItem(0)
If cell.Value Like "?*#?*.?*" And _
Cells(cell.Row, "T") = "Yes" Then
With emailItem
' This is who the email is being sent to
.To = Cells(cell.Row, "S").Value
.CC = Cells(cell.Row, "S").Value
' This is the subject of the email
.Subject = "Status update"
' This is the body of the email based on cell references
mymsg = "Dear " & Cells(cell.Row, "A").Value & " team," & vbNewLine & vbNewLine
Dim stts As String
If Cells(cell.Row, 4).Value = "1. New Order" Then
stts = "Your order has been received and will processed."
ElseIf Cells(cell.Row, 4).Value = "2. Shipped" Then
stts "Status: Your order has been shipped" & vbNewLine
Else
End If
mymsg = mymsg & "Status: " & stts
mymsg = mymsg & "Deposit invoice: " & Cells(cell.Row, "K").Value & vbNewLine
mymsg = mymsg & "Additional invoice: " & Cells(cell.Row, "M").Value & vbNewLine
.Body = mymsg
.Send
' This part brings the loop back up to the top, so this way it goes to the next email in the column
End With
On Error GoTo 0
Set emailItem = Nothing
End If
Next cell
cleanup:
Set emailApplication = Nothing
Set emailItem = Nothing
Set mymsg = Nothing
Application.ScreenUpdating = True
End Sub
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
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
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
I have a spreadsheet that is going to be used to track requests made to another department. I would like a Macro to generate and send an email the contains some predefined text and the value of some variables. I already have some working code that scans the relevant cells and stores their values.
I can generate the email, I can print lines of text including inserting one variable into the subject, but I can't seem to insert the value of any of the variables in the middle of the body of the email. I have the following:
Sub IssueRequest()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
' Selecting the last entry in column "B"
Range("B7").Select
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
' Collect the unique value to insert into the subject field
Dim Subject As String
Subject = ActiveCell.Value
ActiveCell.Offset(0, 2).Select
' Collect the Part Number for use in the body of the email
Dim PartNumber As String
PartNumber = ActiveCell.Value
' Collect the Quantity for use in the body of the email
ActiveCell.Offset(0, 1).Select
Dim Qty As String
Qty = ActiveCell.Value
'Create the email
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Hi guys," & vbNewLine & vbNewLine & _
"Please can you issue the following:" & vbNewLine & vbNewLine & _
"Part number: " & vbNewLine & _
"Qty: " & vbNewLine & _
"This is line 4"
On Error Resume Next
With OutMail
.To = "xxxxx.xxxxx#xxxxx-xxxxx.com"
.CC = ""
.BCC = ""
.Subject = Subject
.Body = strbody
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub*
I really need to be able to insert the values of PartNumber and Qty in the middle of the String strbody.
strbody = "Hi guys," & vbNewLine & vbNewLine & _
"Please can you issue the following:" & vbNewLine & vbNewLine & _
"Part number: " & PartNumber & vbNewLine & _
"Qty: " & Qty & vbNewLine & _
"This is line 4"
Just include the PartNumber and Qty variable names inside the part of code where you're creating the e-mail body string; remember to use the & operator to join string variables together.