I would like to send an e-mail with outlook based on the query results from my table but with table formatting (in the body). For some reason the code is only outputting the last record in the table to the e-mail body, instead of looping and adding all 3 records.
Any suggestions, or a better way to code this?
Public Sub NewEmail()
'On Error GoTo Errorhandler
Dim olApp As Object
Dim olItem As Variant
Dim olatt As String
Dim olMailTem As Variant
Dim strSendTo As String
Dim strMsg As String
Dim strTo As String
Dim strcc As String
Dim rst As DAO.Recordset
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim qry As DAO.QueryDef
Dim fld As Field
Dim varItem As Variant
Dim strtable As String
Dim rec As DAO.Recordset
Dim strqry As String
strqry = "SELECT * From Email_Query"
strSendTo = "test#email.com"
strTo = ""
strcc = ""
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(olMailTem)
olItem.Display
olItem.To = strTo
olItem.CC = strcc
olItem.Body = ""
olItem.Subject = "Test E-mail"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strqry)
If Not (rec.BOF And rec.EOF) Then
rec.MoveLast
rec.MoveFirst
intCount = rec.RecordCount
For intLoop = 1 To intCount
olItem.HTMLBody = "<HTML><body>" & _
"<table border='2'>" & _
"<tr>" & _
"<th> Request Type </th>" & _
"<th> ID </th>" & _
"<th> Title </th>" & _
"<th> Requestor Name </th>" & _
"<th> Intended Audience </th>" & _
"<th> Date of Request</th>" & _
"<th> Date Needed </th>" & _
"</tr>" & _
"<tr>" & _
"<td>" & rec("Test1") & "</td>" & _
"<td>" & rec("Test2") & "</td>" & _
"<td>" & rec("Test3") & "</td>" & _
"<td>" & rec("Test4") & "</td>" & _
"<td>" & rec("Test5") & "</td>" & _
"<td>" & rec("Test6") & "</td>" & _
"<td>" & rec("Test7") & "</td>" & _
"</tr>" & _
"<body><HTML>"
rec.MoveNext
Next intLoop
End If
MsgBox "E-mail Sent"
Set olApp = Nothing
Set olItem = Nothing
Exit_Command21_Click:
Exit Sub
ErrorHandler:
MsgBox Err.Description, , Err.Number
Resume Exit_Command21_Click
End Sub
You're changing the HTMLBody every loop rather than adding to it. You should set your header row above the loop, then set each row inside the loop. I like to fill up arrays and use the Join function - it's more visually pleasing to me.
Public Sub NewEmail()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 7) As String
Dim aRow(1 To 7) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Request Type"
aHead(2) = "ID"
aHead(3) = "Title"
aHead(4) = "Requestor Name"
aHead(5) = "Intended Audience"
aHead(6) = "Date of Request"
aHead(7) = "Date Needed"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'Create each body row
strQry = "SELECT * From Email_Query"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("Test1")
aRow(2) = rec("Test2")
aRow(3) = rec("Test3")
aRow(4) = rec("Test4")
aRow(5) = rec("Test5")
aRow(6) = rec("Test6")
aRow(7) = rec("Test7")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.display
olItem.To = "example#example.com"
olItem.Subject = "Test E-mail"
olItem.htmlbody = Join(aBody, vbNewLine)
olItem.display
End Sub
Related
I wrote code to pick up unread email and with other criteria.
The code runs but For Each itm In olFolder.Items.Restrict(sFilter) is not working.
For example if there are 4 unread emails in the inbox the For Each should loop 4 times but the loop is happening only 2 times.
Sub ReadOutlookEmails_WithCriteria()
Dim olApp As Outlook.Application, olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder, olMail As Outlook.MailItem
Dim eFolder As Outlook.Folder '~~> additional declaration
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim objAtt As Outlook.Attachment
Dim olItem As Outlook.MailItem
Dim olReply As MailItem ' Reply
Dim olRecip As Recipient
Dim i As Long
Dim x As Date, ws As Worksheet '~~> declare WS variable instead
Dim lrow As Long '~~> additional declaration
Set ws = ActiveSheet '~~> or you can be more explicit using the next line
Set EC = ThisWorkbook.Sheets("Email Search Criteria")
Set IE = ThisWorkbook.Sheets("Inbox Emails")
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Rejected Emails")
Todays_Date = EC.Range("E2").Value
IE.Rows("2:10000").Clear
Incr = 2
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
If eFolder = "Mandatory Training Enrollment" Then 'IF_Check_1
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name): Debug.Print olFolder
sFilter = "[ReceivedTime] >= '" & Todays_Date & "' AND [UNREAD]=TRUE"
Debug.Print olFolder.Items.Restrict(sFilter).Count
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
For Each itm In olFolder.Items.Restrict(sFilter) ''''Problem is over here
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
If itm.Attachments.Count = EC.Range("B2") Then 'itm Like "*" & EC.Range("A2") & "*" And'IF_Check_2
For Each objAtt In itm.Attachments
Debug.Print "Subject Name - " & itm: Debug.Print "Attachment Type - " & objAtt.DisplayName
Debug.Print "Attachment Size - " & objAtt.Size: Debug.Print "Attachments Count - " & objAtt.Index
Debug.Print "Subject Name - " & EC.Range("A2"): Debug.Print "Attachment Type - " & EC.Range("C2")
Debug.Print "Attachment Size - " & EC.Range("D2"): Debug.Print "Attachments Count - " & EC.Range("B2")
If objAtt.Size <= EC.Range("D2") And UCase(objAtt.Filename) Like UCase("*" & EC.Range("C2")) Then
IE.Range("A" & Incr) = olFolder
IE.Range("B" & Incr) = itm.SenderName
IE.Range("C" & Incr) = itm
IE.Range("D" & Incr) = objAtt.DisplayName
IE.Range("E" & Incr) = itm.Attachments.Count
IE.Range("F" & Incr) = objAtt.Size
IE.Range("G" & Incr) = "Pass"
Set olReply = itm.ReplyAll
'Set olRecip = olReply.Recipients.Add("Email Address Here") ' Recipient Address
'olRecip.Type = olCC
olReply.Body = "Hello," & vbNewLine & vbNewLine & "Email Success" & vbNewLine & vbNewLine & "Thank you. " & vbCrLf & olReply.Body
olReply.Display
'olReply.SentOnBehalfOfName = onBehalfOf
'olReply.SendUsingAccount = getGenericMailboxAccount(onBehalfOf)
olReply.Send
itm.UnRead = False
End If
Next objAtt
ElseIf itm.Attachments.Count <> EC.Range("B2") Then 'IF_Check_2
FailReason1 = "Attament is not a PDF"
FailReason2 = "Attachment size is more than 10MB"
FailReason3 = "Attachment is missing with email"
FailReason4 = "Attachments are more than 1"
IE.Range("A" & Incr) = olFolder
IE.Range("B" & Incr) = itm.SenderName
IE.Range("C" & Incr) = itm
IE.Range("D" & Incr) = ""
IE.Range("E" & Incr) = itm.Attachments.Count
IE.Range("F" & Incr) = ""
IE.Range("G" & Incr) = "Fail"
EBody = "Hello," & vbNewLine & vbNewLine & "Email Not Success." & vbNewLine & vbNewLine _
& "Fail Reason Might Be One Of The Below Mentioned:" & vbNewLine & vbNewLine _
& "*" & FailReason1 & vbNewLine & vbNewLine _
& "*" & FailReason2 & vbNewLine & vbNewLine _
& "*" & FailReason3 & vbNewLine & vbNewLine _
& "*" & FailReason4 & vbNewLine & vbNewLine _
Set olReply = itm.ReplyAll
'Set olRecip = olReply.Recipients.Add("Email Address Here") ' Recipient Address
'olRecip.Type = olCC
'olReply.Body = "Hello," & vbCrLf & "Email Not Success" & vbCrLf & FailReason1 & vbCrLf & FailReason2 & vbCrLf & FailReason3 & vbCrLf & olReply.Body
olReply.Body = EBody & vbCrLf & olReply.Body
olReply.Display
'olReply.SentOnBehalfOfName = onBehalfOf
'olReply.SendUsingAccount = getGenericMailboxAccount(onBehalfOf)
olReply.Send
itm.UnRead = False
itm.Move SubFolder
End If 'IF_Check_2
Incr = Incr + 1
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Next itm ' Its passing to the next statement even though loop is not completed.
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Set olFolder = Nothing
End If ''IF_Check_1
Next eFolder
End Sub
Your are modifying (by setting the Unread property to false) the very collection you are iterating over.
Do not use foreach - use a down loop.
set restrItems = olFolder.Items.Restrict(sFilter)
For i = restrItems.Count to 1 Step -1
set itm = restrItems(i)
First of all, you need to make sure the date object is formatted in the way Outlook understands:
sFilter = "[ReceivedTime] >= '" & Todays_Date & "' AND [UNREAD]=TRUE"
Use the Format function available in VBA.
sFilter = "[ReceivedTime] > '" & Format(Todays_Date, "ddddd h:nn AMPM") & "'"
VBA Email Generator - Send Notice to Employee with Overdue Tickets
Trying to generate emails to notify user that their ticket is overdue. The program runs and generates the email, however if a employee has multiple tickets overdue, it sends them multiple emails as opposed to one with all overdue items.
Your help is really appreciated!!!!
Option Compare Database
Option Explicit
Public Sub SendSerialEmail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
Dim strQry As String
Dim aHead(1 To 6) As String
Dim aRow(1 To 6) As String
Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outStarted As Boolean
'Create the header row
aHead(1) = "Ticket#"
aHead(2) = "Summary"
aHead(3) = "Ticket Status"
aHead(4) = "Date Created"
aHead(5) = "# Business Days Open"
aHead(6) = "Assigned To"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
Do Until rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("ID")
aRow(2) = rec("title")
aRow(3) = rec("name")
aRow(4) = rec("created")
aRow(5) = rec("workdaysopen")
aRow(6) = rec("full_name")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
If outStarted Then
outApp.Quit
End If
Do Until rs.EOF
emailTo = rs.Fields("email").Value
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.CC = "myemail#gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<BODY style=font-size:11pt;font-family:Segoe UI>" & "Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<BODY style=font-size:14pt;font-family:Segoe UI>" & "<b><span style=""color:#B22222"">Overdue Termination Tickets</b>" & _
Join(aBody, vbNewLine) & _
"<br>" & _
"<BODY style=font-size:11pt;font-family:Segoe UI>" & "<b><i><span style=""color:#000000"">**Please note that tickets are overdue.</i></b>"
outMail.Display
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
I'll invite your to test the following code, I've made a test of this code.
The idea is to check if an email address has already been used, in order to send a single email per user.
Send all tickets to all users with 1-single email per user
Public Function IsEmailInArray(strEmail As String, arr() As String, lUbound As Long) As Boolean
Dim i
For i = 1 To lUbound
If arr(i) = strEmail Then
IsEmailInArray = True
Exit Function
End If
Next
IsEmailInArray = False
End Function
Public Sub so66016960SendSerialEmail()
Dim db As DAO.Database
Dim rs As DAO.Recordset
'Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
Dim strQry As String
Dim aHead(1 To 6) As String
Dim aRow(1 To 6) As String
Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outStarted As Boolean
Dim strTable As String
'Create the header row
aHead(1) = "Ticket#"
aHead(2) = "Summary"
aHead(3) = "Ticket Status"
aHead(4) = "Date Created"
aHead(5) = "# Business Days Open"
aHead(6) = "Assigned To"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
'
' get listing table of all overdue tickets:
'
Do Until rs.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rs("ID")
aRow(2) = rs("title")
aRow(3) = rs("name")
aRow(4) = rs("created")
aRow(5) = rs("workdaysopen")
aRow(6) = rs("full_name")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rs.MoveNext
Loop
aBody(lCnt) = aBody(lCnt) & "</table>"
'
strTable = Join(aBody, vbNewLine)
'
'If outStarted Then
' outApp.Quit
'End If
'
'
' rewind:
'
rs.MoveFirst
'
' now we reuse aBody() array as temporay array to used email addresses:
'
lCnt = 0
'
Do Until rs.EOF
emailTo = rs.Fields("email").Value
'
' if email is not yet used:
'
If (Not IsEmailInArray(emailTo, aBody, lCnt)) Then
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = emailTo
outMail.CC = "myemail#gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" & _
"Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" & _
strTable & _
"<br>" & _
"<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" & _
"</body></html>"
outMail.Display
'
' memory the email address just sent:
'
lCnt = lCnt + 1
aBody(lCnt) = emailTo
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
To send email with only her/his own information, we ORDER BY email, like this:
Public Function send1Mail(ByVal outApp, ByVal strEmail2Use, ByVal nameemployee, ByVal emailSubject, ByVal emailText, ByVal strTable)
Dim outMail As Outlook.MailItem
Set outMail = outApp.CreateItem(olMailItem)
outMail.To = strEmail2Use
outMail.CC = "myemail#gmail.com"
outMail.Subject = emailSubject
outMail.HTMLBody = "<html><body style=font-size:11pt;font-family:Segoe UI>" & _
"Hi " & nameemployee & "," & _
"<br>" & "<br>" & _
"<b><span style=""font-size:14pt;font-family:Segoe UI;color:#B22222"">Overdue Termination Tickets</b>" & _
strTable & _
"<br>" & _
"<b><i><span style=""font-size:11pt;font-family:Segoe UI;color:#000000"">**Please note that tickets are overdue.</i></b>" & _
"</body></html>"
outMail.Display
Set outMail = Nothing
send1Mail = 1
End Function
Public Sub SendSerialEmail2Each()
Dim db As DAO.Database
Dim rs As DAO.Recordset
'Dim rec As DAO.Recordset
Dim emailTo As String
Dim nameemployee As String
Dim emailSubject As String
Dim emailText As String
'Dim strQry As String
'Dim aHead(1 To 6) As String
'Dim aRow(1 To 6) As String
'Dim aBody() As String
Dim lCnt As Long
Dim outApp As Outlook.Application
'Dim outMail As Outlook.MailItem
Dim outStarted As Boolean
'
' nRows: number of rows in the table
' strTable: html table
' strTableHeader: html table header
' strEmail2Use: email address to send message
'
Dim nRows As Long
Dim strTable As String, strTableHeader As String, strEmail2Use As String
'Create the header row
' aHead(1) = "Ticket#"
' aHead(2) = "Summary"
' aHead(3) = "Ticket Status"
' aHead(4) = "Date Created"
' aHead(5) = "# Business Days Open"
' aHead(6) = "Assigned To"
' lCnt = 1
' ReDim aBody(1 To lCnt)
' strTableHeader = "<table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'
strTableHeader = "<table border='2'>" & _
"<tr>" & _
"<th>Ticket#</th>" & _
"<th>Title</th>" & _
"<th>Name</th>" & _
"<th>Date Create</th>" & _
"<th># Business Days Open</th>" & _
"<th>Assigned To</th>" & _
"</tr>"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outStarted = True
End If
Set db = CurrentDb
'
' ORDRER BY email is important here:
'
Set rs = db.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets ORDER BY email;")
' Set rec = CurrentDb.OpenRecordset("SELECT ID, title, name, created, workdaysopen, full_name, email FROM OverdueTerminationTickets")
nRows = rs.RecordCount
'
' initialize:
'
lCnt = 0
strEmail2Use = ""
strTable = ""
'
Do Until rs.EOF
lCnt = lCnt + 1
'
' get email of the current record:
'
emailTo = rs.Fields("email").Value
'
' if first record: save email address and name.
'
If (lCnt = 1) Then
strEmail2Use = emailTo
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
'
' send the email if address changes:
'
ElseIf (strEmail2Use <> emailTo) Then
'
' close the html table:
'
strTable = strTableHeader & strTable & "</table>"
'
' send 1 single mail:
'
send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable
strEmail2Use = emailTo
nameemployee = rs.Fields("full_name")
emailSubject = "Termination Tickets Overdue" & " - " & Date
emailText = Trim("Hi " & rs.Fields("full_name").Value) & ","
strTable = ""
End If
'
' aggregate all records per user for tr's:
'
strTable = strTable & _
"<tr>" & _
"<td>" & rs("ID") & "</td>" & _
"<td>" & rs("title") & "</td>" & _
"<td>" & rs("name") & "</td>" & _
"<td>" & rs("created") & "</td>" & _
"<td>" & rs("workdaysopen") & "</td>" & _
"<td>" & rs("full_name") & "</td>" & _
"</tr>"
'
' also send email at the last row of recordset:
'
If (lCnt = nRows) Then
'
' close the html table:
'
strTable = strTableHeader & strTable & "</table>"
'
' send 1 single mail:
'
send1Mail outApp, strEmail2Use, nameemployee, emailSubject, emailText, strTable
'
End If
'
' move next:
'
rs.MoveNext
Loop
'
' do this to save RAM:
'
rs.Close
Set rs = Nothing
Set db = Nothing
If outStarted Then
outApp.Quit
End If
Set outApp = Nothing
End Sub
Tested data Screenshot:
Generating the following Outlook email Windows to click and send.
I'm new to VB in Excel.
I made an email reminder program in Excel with value changed from formula (calculation) in one of the cell.
The problem is the email reminder did not pop up even though the conditions are met.
But when I put manually the number (to meet the condition), the email reminder did pop up.
Please help to make the program run if the cell value from calculation met the condition of the program. Thanks!
Here is the code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim completed As Boolean
Dim rowCount As Long
Dim i As Integer
Dim Objek As String
Dim SatKer As String
Dim Hari As String
Dim AlamatEmail As String
Dim xMailBody As String
rowCount = 2
If Target.Cells.Count > 1 Then Exit Sub
For i = 1 To 5
rowCount = rowCount + 1
Set xRg = Range("O" & CStr(rowCount))
Objek = ActiveSheet.Range("F" & CStr(rowCount)).Value
SatKer = ActiveSheet.Range("G" & CStr(rowCount)).Value
Hari = ActiveSheet.Range("O" & CStr(rowCount)).Value
AlamatEmail = ActiveSheet.Range("S" & CStr(rowCount)).Value
If xRg = Target And Target.Value < 4 Then
Call Mail_small_Text_Outlook(Objek, SatKer, Hari, AlamatEmail)
End If
Next i
End Sub
Sub Mail_small_Text_Outlook(Objek As String, SatKer As String, Hari As String, AlamatEmail As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Yth. Bapak Widi " & vbNewLine & vbNewLine & _
"Laporan Penilaian " & Objek & " milik " & SatKer & " mendekati batas akhir pengumpulan." & vbNewLine & _
"Laporan tersebut harus disubmit dalam " & Hari & " hari." & vbNewLine & vbNewLine & _
"Mohon cek status laporan penilaian untuk keterangan laporan lebih detail."
On Error Resume Next
With xOutMail
.To = AlamatEmail
.cc = ""
.BCC = ""
.Subject = "Laporan Penilaian " & Objek & " milik " & SatKer
.HTMLBody = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
The following should do what you expect, the code will loop through column O and if the value calculated is less than 4 then it will .Display the email:
Private Sub Worksheet_Calculate()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastRow = ws.Cells(ws.Rows.Count, "O").End(xlUp).Row
'get the last row with data on Column O
Dim completed As Boolean
Dim rowCount As Long
Dim i As Integer
Dim Objek As String
Dim SatKer As String
Dim Hari As String
Dim AlamatEmail As String
Dim xMailBody As String
For i = 3 To LastRow 'loop from row 3 to last on Column O
Set xRg = Range("O" & i)
Objek = ws.Range("F" & i).Value
SatKer = ws.Range("G" & i).Value
Hari = ws.Range("O" & i).Value
AlamatEmail = ws.Range("S" & i).Value
If ws.Cells(i, "O").Value < 4 Then 'if value is less than 4 then send email
Call Mail_small_Text_Outlook(Objek, SatKer, Hari, AlamatEmail)
End If
Next i
End Sub
Sub Mail_small_Text_Outlook(Objek As String, SatKer As String, Hari As String, AlamatEmail As String)
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Yth. Bapak Widi " & vbNewLine & vbNewLine & _
"Laporan Penilaian " & Objek & " milik " & SatKer & " mendekati batas akhir pengumpulan." & vbNewLine & _
"Laporan tersebut harus disubmit dalam " & Hari & " hari." & vbNewLine & vbNewLine & _
"Mohon cek status laporan penilaian untuk keterangan laporan lebih detail."
On Error Resume Next
With xOutMail
.To = AlamatEmail
.cc = ""
.BCC = ""
.Subject = "Laporan Penilaian " & Objek & " milik " & SatKer
.HTMLBody = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Emails I send through excel do not display the embedded images on the receivers end. However the embedded images do display on my end. My guess is that the path is associated with my desktop.
How can I get the images to be displayed? Having trouble figuring out a fix. My code is below:
Sub EmailDailyFlow()
Dim mainWB As Workbook
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
Set mainWB = ActiveWorkbook
With olMail
.To = "email#gmail.com"
.Cc = ""
.Subject = Format(Date - 1, "M.dd.yyyy") & " " & "MF & VIT Daily Fund Flow"
.HTMLBody = "<html><body style='font-family: Times New Roman, Times, serif; font-size: 16px;'>" & _
"<p>Please see below.</p>" & _
"<p><u><b>Volatility:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\MF.png'>" & _
"<p><u><b>Muni:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\MUNI.png'>" & _
"<p><u><b>AFC:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\AFC.png'>" & _
"<p><u><b>AFT:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\AFT.png'>" & _
"<p><u><b>VIT:</u></b></p>" & _
"<img src='C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\VIT.png'>" & _
"<p>Thank you,</p>" & _
"</body></html>"
.Send
End With
MsgBox ("Daily flow emails sent!")
End Sub`
Try this code. Taken from some site long back, but still work like a charm.
Idea is to attach the image in hidden manner and later add it to using image name in the HtmlBody.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Update:
I've added another function to retrieve image width and height. I've also updated existing sub to incorporate image size.
Sub EmailDailyFlow()
Dim SendID
Dim CCID
Dim Subject
Dim stdPic As StdPicture
Dim imageSize As String
Dim strPathImg1 As String
Dim strFileImg1 As String
Dim lngWidthImg1 As Long
Dim lngHeightImg1 As Long
Dim strPathImg2 As String
Dim strFileImg2 As String
Dim lngWidthImg2 As Long
Dim lngHeightImg2 As Long
Dim olMail As MailItem 'REQUIRES MICROSOFT OBJECT OUTLOOK LIBRARY REFERENCE
strPathImg1 = "C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images"
strFileImg1 = "MF.png"
imageSize = GetImageSize(strPathImg1, strFileImg1)
lngWidthImg1 = CLng(Split(imageSize, ":")(0))
lngHeightImg1 = CLng(Split(imageSize, ":")(1))
strPathImg2 = "C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images"
strFileImg2 = "MUNI.png"
imageSize = GetImageSize(strPathImg2, strFileImg2)
lngWidthImg2 = CLng(Split(imageSize, ":")(0))
lngHeightImg2 = CLng(Split(imageSize, ":")(1))
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(olMailItem)
SendID = "email#gmail.com"
CCID = ""
Subject = Format(Date - 1, "M.dd.yyyy") & " " & "MF & VIT Daily Fund Flow"
With olMail
.To = SendID
If CCID <> "" Then
.CC = CCID
End If
.Subject = Subject
'ADD THE IMAGE IN HIDDEN MANNER, POSITION AT 0 WILL MAKE IT HIDDEN
.Attachments.Add strPathImg1 & "\" & strFileImg1, olByValue, 0
.Attachments.Add strPathImg2 & "\" & strFileImg2, olByValue, 0
'NOW ADD IT TO THE HTML BODY USING IMAGE NAME
'CHANGE THE SRC PROPERTY TO 'cid:your image filename'
'IT WILL BE CHANGED TO THE CORRECT CID WHEN ITS SENT.
.HTMLBody = "<html><body style='font-family: Times New Roman, Times, serif; font-size: 16px;'>" & _
"<p>Please see below.</p>" & _
"<p><u><b>Volatility:</u></b></p>" & _
"<img src='cid:" & strFileImg1 & "' width='" & lngWidthImg1 & "' height='" & lngHeightImg1 & "'>" & _
"<p><u><b>Muni:</u></b></p>" & _
"<img src='cid:" & strFileImg2 & "' width='" & lngWidthImg2 & "' height='" & lngHeightImg2 & "'>" & _
"<p><u><b>AFC:</u></b></p>" & _
"<p>Thank you,</p>" & _
"</body></html>"
'.Display 'UNCOMMENT ME IF YOU WANT TO DISPLAY THE EMAIL
.Send
End With
MsgBox ("Daily flow emails sent!")
End Sub
Function GetImageSize(filePath As String, fileName As String) As String
'THIS WILL RETURN IMAGE SIZE IN "xyz:xyz" STRING FORMAT
Dim strImageDimensions As String
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace((filePath))
Set objFile = objFolder.ParseName(fileName)
strImageDimensions = objFile.ExtendedProperty("Dimensions")
strImageDimensions = Replace(Mid(strImageDimensions, 2, Len(strImageDimensions) - 2), " x ", ":")
GetImageSize = strImageDimensions
Set objFile = Nothing: Set objFolder = Nothing: Set objShell = Nothing
End Function
Sub EmailDailyFlow()
Dim oApp As Outlook.Application
Dim oEmail As MailItem
Dim colAttach As Outlook.Attachments
Dim oAttach1 As Outlook.Attachment
Dim oAttach2 As Outlook.Attachment
Dim oAttach3 As Outlook.Attachment
Dim oAttach4 As Outlook.Attachment
Dim oAttach5 As Outlook.Attachment
Dim olkPA As Outlook.PropertyAccessor
Const PR_ATTACH_CONTENT_ID="http://schemas.microsoft.com/mapi/proptag/0x3712001F"
Set oApp = CreateObject("Outlook.Application")
Set oEmail = oApp.CreateItem(olMailItem)
Set colAttach = oEmail.Attachments
Set oAttach1 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\MF.png")
Set oAttach2 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\Muni.png")
Set oAttach3 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\AFC.png")
Set oAttach4 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\AFT.png")
Set oAttach5 = colAttach.Add("C:\Users\Name\Desktop\MF-VIT Daily Fund Flow\images\VIT.png")
Set olkPA1 = oAttach1.PropertyAccessor
Set olkPA2 = oAttach2.PropertyAccessor
Set olkPA3 = oAttach3.PropertyAccessor
Set olkPA4 = oAttach4.PropertyAccessor
Set olkPA5 = oAttach5.PropertyAccessor
olkPA1.SetProperty PR_ATTACH_CONTENT_ID, "MF.png"
olkPA2.SetProperty PR_ATTACH_CONTENT_ID, "MUNI.png"
olkPA3.SetProperty PR_ATTACH_CONTENT_ID, "AFC.png"
olkPA4.SetProperty PR_ATTACH_CONTENT_ID, "AFT.png"
olkPA5.SetProperty PR_ATTACH_CONTENT_ID, "VIT.png"
oEmail.Close olSave
oEmail.HTMLBody = "<body style='font-family: Times New Roman, Times, serif; font-size: 16px;'><p>Please see below.</p>" & _
"<img src='cid:MF.png'>" & _
"<p><u><b>Muni:</u></b></p>" & _
"<img src='cid:MUNI.png'>" & _
"<p><u><b>afcCore:</u></b></p>" & _
"<img src='cid:AFC.png'>" & _
"<p><u><b>aft:</u></b></p>" & _
"<img src='cid:AFT.png'>" & _
"<p><u><b>VIT:</u></b></p>" & _
"<img src='cid:VIT.png'>" & _
"<p>Thank you,</p>" & _
"</body>"
oEmail.Save
oEmail.To = "email#email.com"
oEmail.CC = ""
oEmail.Subject = Format(Date - 1, "M.dd.yyyy") & " " & "MF & VIT Daily Fund Flow"
oEmail.Send
Set oEmail = Nothing
Set colAttach = Nothing
Set oAttach = Nothing
Set oApp = Nothing
End Sub
I sent an outlook (2010) meeting request to all company (4000+) and now I would like to send an additional email to those who accepted the request or accepted tentatively.
How do I do that? When I hit Contact Atendees --> New Email to Atendees in the ribbon it just send a response to all company and not only those who accepted. I also tried to export the contacts but it can only export the name alias and not the entire email addresses.
Any suggestions?
Thanks
The basis of the solution is found here Get Meeting Attendee List Macro
Here it is with minor changes.
Option Explicit
Sub GetAttendeeList()
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strCopyData As String
Dim strCount As String
Dim ino, it, ia, ide
Dim x As Long
Dim ListAttendees As mailitem
'On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objItem = GetCurrentItem()
Set objAttendees = objItem.Recipients
On Error GoTo EndClean:
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "This code only works with meetings."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.location
strNotes = objItem.body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
Set ListAttendees = Application.CreateItem(olMailItem) ' <---
' Get The Attendee List
For x = 1 To objAttendees.count
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response (or Organizer)"
ino = ino + 1
Case 1
strMeetStatus = "Organizer"
ino = ino + 1
Case 2
strMeetStatus = "Tentative"
it = it + 1
ListAttendees.Recipients.Add objAttendees(x) ' <---
Case 3
strMeetStatus = "Accepted"
ia = ia + 1
ListAttendees.Recipients.Add objAttendees(x) ' <---
Case 4
strMeetStatus = "Declined"
ide = ide + 1
End Select
If objAttendees(x).Type = olRequired Then
objAttendeeReq = objAttendeeReq & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
Else
objAttendeeOpt = objAttendeeOpt & objAttendees(x).Name & vbTab & strMeetStatus & vbCrLf
End If
Next
strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject: " & strSubject & vbCrLf & _
"Location: " & strLocation & vbCrLf & "Start: " & dtStart & vbCrLf & "End: " & dtEnd & _
vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes
strCount = "Accepted: " & ia & vbCrLf & _
"Declined: " & ide & vbCrLf & _
"Tentative: " & it & vbCrLf & _
"No response: " & ino
'Set ListAttendees = Application.CreateItem(olMailItem)
ListAttendees.body = strCopyData & vbCrLf & strCount
ListAttendees.Display
ListAttendees.Recipients.ResolveAll ' <---
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objAttendees = Nothing
End Sub
Building upon what #niton wrote, I've added support for checking against the Global Address List. This code could be extended to search all address lists available to you by iterating through myAddressLists, however, in most cases, that will probably be more than wanted.
Note that this isn't optimized for speed, but even a list with a few hundred people invited against a GAL of tens of thousands won't take a computer very long to iterate through. Since this doesn't get run very often, the time saved for optimizing this just didn't seem worth it.
Option Explicit
Sub GetAttendeeList()
Dim x As Integer
Dim y As Integer
Dim ino As Integer
Dim it As Integer
Dim ia As Integer
Dim ide As Integer
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objAttendees As Outlook.Recipients
Dim objAttendeeReq As String
Dim objAttendeeOpt As String
Dim strAttendeeName As String
Dim strAttendeeEmail As String
Dim objOrganizer As String
Dim dtStart As Date
Dim dtEnd As Date
Dim strSubject As String
Dim strLocation As String
Dim strNotes As String
Dim strMeetStatus As String
Dim strCopyData As String
Dim strCount As String
Dim strCity As String
Dim folContacts As Outlook.MAPIFolder
Dim oContact As Outlook.ContactItem
Dim colItems As Outlook.Items
Dim oNS As Outlook.NameSpace
Dim ListAttendees As MailItem
Dim strNewRecord As String
Dim myAddressLists As AddressLists
Dim myAddressEntries As AddressEntries
Dim myAddressEntry As AddressEntry
Dim myExchangeUser As ExchangeUser
Dim myExchangeDL As ExchangeDistributionList
Dim myContactItem As ContactItem
On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
Set myAddressLists = oNS.AddressLists
Set myAddressEntries = myAddressLists.Item("Global Address List").AddressEntries
Set objItem = GetCurrentItem()
Set objAttendees = objItem.Recipients
On Error GoTo EndClean:
' Is it an appointment
If objItem.Class <> 26 Then
MsgBox "This code only works with meetings."
GoTo EndClean:
End If
' Get the data
dtStart = objItem.Start
dtEnd = objItem.End
strSubject = objItem.Subject
strLocation = objItem.Location
strNotes = objItem.Body
objOrganizer = objItem.Organizer
objAttendeeReq = ""
objAttendeeOpt = ""
' Get The Attendee List
For x = 1 To objAttendees.Count
strMeetStatus = ""
Select Case objAttendees(x).MeetingResponseStatus
Case 0
strMeetStatus = "No Response (or Organizer)"
ino = ino + 1
Case 1
strMeetStatus = "Organizer"
ino = ino + 1
Case 2
strMeetStatus = "Tentative"
it = it + 1
Case 3
strMeetStatus = "Accepted"
ia = ia + 1
Case 4
strMeetStatus = "Declined"
ide = ide + 1
End Select
strAttendeeName = objAttendees(x).Name
strAttendeeEmail = objAttendees(x).Address
Set oContact = colItems.Find("[Email1Address] = '" & strAttendeeEmail & "'")
If Not oContact Is Nothing Then
Debug.Print "Test", oContact.BusinessAddressCity
strCity = oContact.MailingAddressCity & ", " & oContact.MailingAddressState
End If
If InStr(strAttendeeEmail, "#") = 0 Then
Debug.Print "Searching: " & objAttendees(x).Name
Set myAddressEntry = myAddressEntries.GetFirst()
Do While Not myAddressEntry Is Nothing
If myAddressEntry.Address Like objAttendees(x).Address Then
Debug.Print "Found: " & myAddressEntry.Name
Set myExchangeUser = myAddressEntry.GetExchangeUser()
Set myExchangeDL = myAddressEntry.GetExchangeDistributionList()
Set myContactItem = myAddressEntry.GetContact()
If Not myExchangeUser Is Nothing Then
strAttendeeEmail = myExchangeUser.PrimarySmtpAddress
End If
If Not myExchangeDL Is Nothing Then
strAttendeeEmail = myExchangeDL.PrimarySmtpAddress
End If
If Not myContactItem Is Nothing Then
strAttendeeEmail = myContactItem.Email1Address
End If
GoTo ContactFound
End If
Set myAddressEntry = myAddressEntries.GetNext()
Loop
End If
ContactFound:
strNewRecord = objAttendees(x).Name & vbTab & strAttendeeEmail & vbTab & strMeetStatus & vbTab & strCity & vbCrLf
If objAttendees(x).Type = olRequired Then
objAttendeeReq = objAttendeeReq & strNewRecord
Else
objAttendeeOpt = objAttendeeOpt & strNewRecord
End If
Next
strCopyData = "Organizer: " & objOrganizer & vbCrLf & "Subject: " & strSubject & vbCrLf & _
"Location: " & strLocation & vbCrLf & "Start: " & dtStart & vbCrLf & "End: " & dtEnd & _
vbCrLf & vbCrLf & "Required: " & vbCrLf & objAttendeeReq & vbCrLf & "Optional: " & _
vbCrLf & objAttendeeOpt & vbCrLf & "NOTES " & vbCrLf & strNotes
strCount = "Accepted: " & ia & vbCrLf & _
"Declined: " & ide & vbCrLf & _
"Tentative: " & it & vbCrLf & _
"No response: " & ino
Set ListAttendees = Application.CreateItem(olMailItem)
ListAttendees.Body = strCopyData & vbCrLf & strCount & vbCrLf & Time
ListAttendees.Display
EndClean:
Set objApp = Nothing
Set objItem = Nothing
Set objAttendees = Nothing
End Sub
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function