I am trying to put two data tables into an email.
I have VBA code to include one table. The data for the second table is in tEmailData, which relates to the tDistinct_DCMs table as well on the DCM_Email field.
I've provided my current VBA for the email, and the VBA format for the second table.
How can I add that table after the first table and a short paragraph of text?
Option Compare Database
Option Explicit
Public Sub DCMEmailReviewVBA()
Dim rst As DAO.Recordset
Dim olApp As Outlook.Application
Dim objMail As Outlook.MailItem
Dim rst2 As DAO.Recordset
Dim strTableBeg As String
Dim strTableBody As String
Dim strTableEnd As String
Dim strFntNormal As String
Dim strTableHeader As String
Dim strFntEnd As String
Set rst2 = CurrentDb.OpenRecordset("select distinct DCM_email from tDistinct_DCMs")
rst2.MoveFirst
'Create e-mail item
Set olApp = Outlook.Application
Set objMail = olApp.CreateItem(olMailItem)
'Do Until rst2.EOF
Set olApp = Outlook.Application
Set objMail = olApp.CreateItem(olMailItem)
'Define format for output
strTableBeg = "<table border=1 cellpadding=3 cellspacing=0>"
strTableEnd = "</table>"
strTableHeader = "<font size=3 face=" & Chr(34) & "Calibri" & Chr(34) & "><b>" & _
"<tr bgcolor=lightBlue>" & _
"<TD align = 'left'>Status</TD>" & _
"<TD align = 'left'>First Name</TD>" & _
"<TD align = 'left'>Last Name</TD>" & _
"<TD align = 'left'>UIN</TD>" & _
"</tr></b></font>"
strFntNormal = "<font color=black face=" & Chr(34) & "Calibri" & Chr(34) & " size=3>"
strFntEnd = "</font>"
Set rst = CurrentDb.OpenRecordset("SELECT * FROM tFinalDCM_EmailList where DCM_Email='" & rst2!DCM_Email & "' Order by [Cardholder_UIN] asc")
rst.MoveFirst
'Build HTML Output for the DataSet
strTableBody = strTableBeg & strFntNormal & strTableHeader
Do Until rst.EOF
strTableBody = strTableBody & _
"<tr>" & _
"<TD align = 'left'>" & rst![Action] & "</TD>" & _
"<TD align = 'left'>" & rst![Cardholder First Name] & "</TD>" & _
"<TD align = 'left'>" & rst![Cardholder Last Name] & "</TD>" & _
"<TD align = 'left'>" & rst![Cardholder_UIN] & "</TD>" & _
"</tr>"
rst.MoveNext
Loop
'rst.MoveFirst
strTableBody = strTableBody & strFntEnd & strTableEnd
'rst.Close
'Set rst2 = CurrentDb.OpenRecordset("select distinct ch_email from t_TCard_CH_Email")
'rst2.MoveFirst
Call CaptureDCMBodyText
With objMail
'Set body format to HTML
.To = rst2!DCM_Email
.BCC = gDCMEmailBCC
.Subject = gDCMEmailSubject
.BodyFormat = olFormatHTML
.HTMLBody = .HTMLBody & gDCMBodyText
.HTMLBody = .HTMLBody & "<HTML><BODY>" & strFntNormal & strTableBody & " </BODY></HTML>"
.HTMLBody = .HTMLBody & gDCMBodySig
.SentOnBehalfOfName = "..."
.Display
'.Send
End With
rst2.MoveNext
'Loop
Clean_Up:
rst.Close
rst2.Close
Set rst = Nothing
Set rst2 = Nothing
'Set dbs = Nothing
End Sub
Function td(strIn As String) As String
td = "<TD nowrap>" & strIn & "</TD>"
End Function
VBA for desired second table:
strTableBeg = "<table border=1 cellpadding=3 cellspacing=0>"
strTableEnd = "</table>"
strTableHeader = "<font size=3 face=" & Chr(34) & "Calibri" & Chr(34) & "><b>" & _
"<tr bgcolor=lightblue>" & _
"<TD align = 'left'>Card Type</TD>" & _
"<TD align = 'left'>Cardholder</TD>" & _
"<TD align = 'left'>ER or Doc No</TD>" & _
"<TD align = 'center'>Trans Date</TD>" & _
"<TD align = 'left'>Vendor</TD>" & _
"<TD align = 'right'>Trans Amt</TD>" & _
"<TD align = 'left'>TEM Activity Name or P-Card Log No</TD>" & _
"<TD align = 'left'>Status</TD>" & _
"<TD align = 'right'>Aging</TD>" & _
"</tr></b></font>"
strFntNormal = "<font color=black face=" & Chr(34) & "Calibri" & Chr(34) & " size=3>"
strFntEnd = "</font>"
Set rst = CurrentDb.OpenRecordset("SELECT * FROM tEmailData where DCM_email='" & rst2!DCM_Email & "' Order by Cardholder, Card_Type asc")
rst.MoveFirst
'Build HTML Output for the DataSet
strTableBody = strTableBeg & strFntNormal & strTableHeader
Do Until rst.EOF
strTableBody = strTableBody & _
"<tr>" & _
"<TD align = 'left'>" & rst!Card_Type & "</TD>" & _
"<TD align = 'left'>" & rst!Cardholder & "</TD>" & _
"<TD align = 'left'>" & rst!ERNumber_DocNumber & "</TD>" & _
"<TD align = 'center'>" & rst!Trans_Date & "</TD>" & _
"<TD align = 'left'>" & rst!Vendor & "</TD>" & _
"<TD align = 'right'>" & Format(rst!Trans_Amt, "currency") & "</TD>" & _
"<TD align = 'left'>" & rst!ACTIVITY_Log_No & "</TD>" & _
"<TD align = 'left'>" & rst!Status & "</TD>" & _
"<TD align = 'right'>" & rst!Aging & "</TD>" & _
"</tr>"
rst.MoveNext
Loop
I have not looked at your tables yet, but the code to build the Html document is faulty.
.HTMLBody = .HTMLBody & gDCMBodyText
.HTMLBody = .HTMLBody & "<HTML><BODY>" & strFntNormal & strTableBody & " </BODY></HTML>"
.HTMLBody = .HTMLBody & gDCMBodySig
I cannot find gDCMBodyText and no previous statement has placed anything in HtmlBody so why are you concatenating to it?
<HTML> must come first and </HTML> must come last.
You mention in your question you want to include text but I am unclear where.
I suggest something like the following:
Dim Table1 As string ' First table: <table> ... </table>
Dim Table2 As string ' Second table: <table> ... </table>
Dim TextPre As string ' Text to come before first table
Dim TextMid As string ' Text to come between tables
Dim TextPost As string ' Text to come after second table
Assign appropriate values to the above strings then
.HtmlBody = "<html><body>" & vbLf & _
TextPre & vbLf & _
Table1 & vbLf & _
TextMid & vbLf & _
TextPost & vbLf & _
"</body></html>"
Part 2
I would treat this as four different problems: (1) format table 1 correctly, (2) format table 2 correctly, (3) combine tables correctly and (4) create HtmlBody.
For problems such as 1, 2 and 3, I use the routines below. Macro HtmlDoc combines a Head and Body element into a simple Html document. This is no big deal but it does make life a little simpler. Macro PutTextFileUtf8 outputs a string as a UTF-8 file. Note 1: UTF-8 is the default coding for Html files and allows any Unicode character within a file. Note 2: This macro requires a reference to "Microsoft ActiveX Data Objects n.n Library".
I would use these routines to (1) check Table 1 was being created correctly, (2) check Table 2 was being created correctly and (3) check the tables are being combined correctly. If any of the files are not as I wish, I can look at the text file. Looking at the Html body of a mis-formatted email is more difficult.
Function HtmlDoc(ByVal Head As String, ByVal Body As String)
' Returns a simple Hhml document created from Head and Body
HtmlDoc = "<!DOCTYPE html>" & vbLf & "<html>" & vbLf
If Head <> "" Then
HtmlDoc = HtmlDoc & "<head>" & vbLf & Head & vbLf & "</head>" & vbLf
End If
HtmlDoc = HtmlDoc & "<body>" & vbLf & Body & vbLf & "</body>" & vbLf
HtmlDoc = HtmlDoc & "</html>"
End Function
Public Sub PutTextFileUtf8(ByVal PathFileName As String, ByVal FileBody As String)
' Outputs FileBody as a text file (UTF-8 encoding without leading BOM)
' named PathFileName
' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
' Addition to original code says version 2.5. Tested with version 6.1.
' 1Nov16 Copied from http://stackoverflow.com/a/4461250/973283
' but replaced literals with parameters.
' 15Aug17 Discovered routine was adding an LF to the end of the file.
' Added code to discard that LF.
' References: http://stackoverflow.com/a/4461250/973283
' https://www.w3schools.com/asp/ado_ref_stream.asp
Dim BinaryStream As Object
Dim UTFStream As Object
Set UTFStream = CreateObject("adodb.stream")
UTFStream.Type = adTypeText
UTFStream.Mode = adModeReadWrite
UTFStream.Charset = "UTF-8"
' The LineSeparator will be added to the end of FileBody. It is possible
' to select a different value for LineSeparator but I can find nothing to
' suggest it is possible to not add anything to the end of FileBody
UTFStream.LineSeparator = adLF
UTFStream.Open
UTFStream.WriteText FileBody, adWriteLine
UTFStream.Position = 3 'skip BOM
Set BinaryStream = CreateObject("adodb.stream")
BinaryStream.Type = adTypeBinary
BinaryStream.Mode = adModeReadWrite
BinaryStream.Open
UTFStream.CopyTo BinaryStream
' Originally I planned to use "CopyTo Dest, NumChars" to not copy the last
' byte. However, NumChars is described as an integer whereas Position is
' described as Long. I was concerned that by "integer" they mean 16 bits.
BinaryStream.Position = BinaryStream.Position - 1
BinaryStream.SetEOS
UTFStream.Flush
UTFStream.Close
Set UTFStream = Nothing
BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
BinaryStream.Flush
BinaryStream.Close
Set BinaryStream = Nothing
End Sub
Part 3
In <TD align = 'left'>Card Type</TD>, align = 'left' is the default so can be omitted.
More importantly, the align attribute was depreciated in Html 4 and I cannot find it in Html 5. Use of CSS is recommended.
I suggest you output a HEAD element like this:
<head>
<style>
table {border-collapse:collapse;}
td {border-style:solid; border-width:1px; border-color:#BFBFBF;}
tr.bc-lb {background-color:lightblue;}
td.ha-c {text-align:center;}
td.ha-r {text-align:right;}
</style>
<head>
and TR and TD elements like this:
<tr class= “bg-lb”>
<td>Card Type</td>
<td class=“ha-c“>Trans Date</td>"
<td class=“ha-r“>Trans Amt</td>"
table {border-collapse:collapse;} specifies CSS collapse table model. The difference between the collapse and separate models is only visible if you have cell borders. With collapse the borders touch but with separate there is a small gap between them.
td {border-style:solid; border-width:1px; border-color:#BFBFBF;} specifies every cell is to have a solid, thin border that is coloured dark grey which I prefer to black.
tr.bc-lb {background-color:lightblue;} allows me to set the background colour for a row to light blue by including class= “bg-lb”within the TR start tag.
I think the other styles and their use can be deduced from the above information.
Summary
Without access to your system I cannot test any rewritten versions of your code. I hope I have given you enough information to allow you to amend your own code.
Related
Sample content of the existing email:
01131004378-Item1
01121109880-Item2
01983345661-Item3
The macro should extract the numbers from the existing email based on the regex pattern and then display it in a new composed email.
Sub GetValue()
Dim olMail As Outlook.MailItem
Dim Selection As Selection
Dim obj As Object
Set olMail = Application.ActiveExplorer().Selection(1)
Set Selection = ActiveExplorer.Selection
For Each obj In Selection
Set objMsg = Application.CreateItem(olMailItem)
Dim rxp13 As New RegExp
rxp13.Pattern = "(\d{11}(?=[-]))"
rxp13.Global = True
Dim m13 As Match, c13 As MatchCollection
Set c13 = rxp13.Execute(olMail.Body)
Dim item As String
For Each m13 In c13
item = m13.SubMatches(0)
Next
'......DISPLAY EMAIL ......
'--------------------------
With objMsg
.To = "mail#test.com"
.Subject = obj.Subject
.HTMLBody = _
"<HTML><BODY>" & _
"<div style='font-size:10pt;font-family:Verdana'>" & _
"<table style='font-size:10pt;font-family:Verdana'>" & _
"<tr><td><strong>ITEMS</strong></td></tr>" & _
"<tr>" & _
"<td>" & item & "</td>" & _
"</tr>" & _
"</table>" & _
"</div>" & _
"</BODY></HTML>"
.Display
End With
Set objMsg = Nothing
'----------------------------------------------------------------
Next
End Sub
The expected result:
01131004378
01121109880
01983345661
I only got the last one:
01983345661
How to display all the values from the for each loop and put it into the "<td>" & item & "</td>"?
This is because your code was replacing previous item values.
Try this code:
Sub test1()
Const txt = "01131004378-Item1" & vbLf & "01121109880-Item2" & vbLf & "01983345661-Item3"
Const pattern = "<td>#</td>"
Dim rxp13 As New RegExp, m13 As Match, c13 As MatchCollection, item As String
rxp13.pattern = "\d{11}(?=[-])"
rxp13.Global = True
Set c13 = rxp13.Execute(txt)
If c13.Count Then
For Each m13 In c13
item = item & vbLf & Replace(pattern, "#", m13)
Next
item = Mid(item, 2)
Debug.Print _
"<HTML><BODY>" & vbLf & _
"<div style='font-size:10pt;font-family:Verdana'>" & vbLf & _
"<table style='font-size:10pt;font-family:Verdana'>" & vbLf & _
"<tr><td><strong>ITEMS</strong></td></tr>" & vbLf & _
"<tr>" & vbLf & _
item & vbLf & _
"</tr>" & vbLf & _
"</table>" & vbLf & _
"</div>" & vbLf & _
"</BODY></HTML>"
End If
End Sub
Output:
<HTML><BODY>
<div style='font-size:10pt;font-family:Verdana'>
<table style='font-size:10pt;font-family:Verdana'>
<tr><td><strong>ITEMS</strong></td></tr>
<tr>
<td>01131004378</td>
<td>01121109880</td>
<td>01983345661</td>
</tr>
</table>
</div>
</BODY></HTML>
I have a MS Access module that creates Outlook emails to suppliers in our company in a HTML Table. I can make the module create an email for every customer but I can not get the data to filter out to each individual company. For example the module creates a email for "Supplier A" but it still shows "Supplier B" and "Supplier C" results in that email. My current attempt is opening a recordset and using it as SQL Criteria, I although keep getting the error "No value given for one or more required parameters". Any help or direction on what I'm doing wrong is greatly appreciated.
Dim olApp As Outlook.Application
Dim objMail As Outlook.MailItem
Dim myRecipient As Outlook.Recipient
Dim strMsg As String
Dim strbody As String
Dim sqlmsg As String
Dim i As Integer
Dim rowColor As String
Dim strsup As String
Dim supfilter As DAO.Recordset
Dim db As DAO.Database
Dim Maillist As DAO.Recordset
Dim Mailset As DAO.QueryDef
DoCmd.SetWarnings False
Set db = CurrentDb
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Set Maillist = db.OpenRecordset("P086 - Email OOR")
Set Mailset = db.QueryDefs("P086 - SOOR Email Format")
sqlmsg = "SELECT [P086 - Supplier Open Order Report].[Purchase Order ID], [P086 - Supplier Open Order Report].[PO#] AS [STC Job#], Format([Date],""mm/dd/yyyy"") AS [Issued Date], [P086 - Supplier Open Order Report].Supplier, [P086 - Supplier Open Order Report].Quantity, [P086 - Supplier Open Order Report].DeliveryDate AS [Delivery Date], [P086 - Supplier Open Order Report].StatDate AS [Stat Date], [P086 - Supplier Open Order Report].[Till Delivery], [P086 - Supplier Open Order Report].[Quantity In]" _
& " From [P086 - Supplier Open Order Report]" _
& " WHERE [P086 - Supplier Open Order Report].Supplier = '" & Maillist.Fields("Supplier") & "'" _
& " ORDER BY [P086 - Supplier Open Order Report].DeliveryDate;"
rs.Open sqlmsg, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
strMsg = "<table border='1' cellpadding='3' cellspacing='3' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
"<tr>" & _
"<td bgcolor='#B0C4DE'> <b>Purchase Order</b></td>" & _
"<td bgcolor='#B0C4DE'> <b>STC Job#</b></td>" & _
"<td bgcolor='#B0C4DE'> <b>Issue Date</b></td>" & _
"<td bgcolor='#B0C4DE'> <b>Supplier</b></td>" & _
"<td bgcolor='#B0C4DE'> <b>Quantity</b></td>" & _
"<td bgcolor='#B0C4DE'> <b>Quantity Received</b></td>" & _
"<td bgcolor='#B0C4DE'> <b>Delivery Date</b></td>" & _
"<td bgcolor='#B0C4DE'> <b>Stat Date</b></td>" & _
"<td bgcolor='#B0C4DE'> <b>Days Till Delivery</b></td>" & _
"</tr>"
i = 0
Do While Not rs.EOF
If (i Mod 2 = 0) Then
rowColor = "<td bgcolor='#FFFFFF'> "
Else
rowColor = "<td bgcolor='#E1DFDF'> "
End If
Mailset.SQL = sqlmsg
strMsg = strMsg & "<tr>" & _
rowColor & rs.Fields("Purchase Order ID") & "</td>" & _
rowColor & rs.Fields("STC Job#") & "</td>" & _
rowColor & rs.Fields("Issued Date") & "</td>" & _
rowColor & rs.Fields("Supplier") & "</td>" & _
rowColor & rs.Fields("Quantity") & "</td>" & _
rowColor & rs.Fields("Quantity In") & "</td>" & _
rowColor & rs.Fields("Delivery Date") & "</td>" & _
rowColor & rs.Fields("Stat Date") & "</td>" & _
rowColor & rs.Fields("Till Delivery") & "</td>" & _
"</tr>"
rs.MoveNext
Maillist.MoveNext
i = i + 1
Loop
strbody = Chr(12) & "The Raw Material Auto Order Screen Must Have the 5000 Serial Number Inserted To Be Remove From This Alert." & _
Chr(12) & "Raw Material QM34 Process Sheets Required For All Inventory Purchases. Stock Number(s) Are Provided In This Email."
strMsg = strMsg & "</table>" & strbody
Set olApp = Outlook.Application
Set Maillist = db.OpenRecordset("P086 - Email OOR")
Do Until Maillist.EOF
Set objMail = olApp.CreateItem(olMailItem)
objMail.To = Maillist("emailaddress")
With objMail
.BodyFormat = olFormatHTML
.HTMLBody = "<Font size =""3"">" & strMsg & "</font>"
.Subject = "Supplier Open Order Report " & Date
'.Send 'if you want to send it directly without displaying on screen
.Display ' to display on screen before send
End With
Maillist.MoveNext
Loop
Set olApp = Nothing
Set objMail = Nothing
End Function
Criteria for text type fields require delimiters. Options are apostrophe or doubled quote marks. I prefer apostrophe as it is easier to read. A date/time field would need # delimiter.
& " WHERE [P086 - Supplier Open Order Report].Supplier = '" & Maillist!Supplier & "'" _
Don't need all those parens, don't need to concatentate empty string, don't need .Fields - alternative syntax for referencing field.
For more info, review INSERT INTO - errors, but allows input into table
As for data that is sent, it is compiled only once outside recordset Maillist loop. Code logic is wrong. Modify procedure to compile data for each Maillist record within its loop.
Also, really need to create Outlook application object only once so do that and close it outside loops. The email object is different.
Set olApp = Outlook.Application
Set Maillist = db.OpenRecordset("P086 - Email OOR")
Do Until Maillist.EOF
sqlmsg = ...
rs.Open sqlmsg, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
...
Do While Not rs.EOF
...
Loop
rs.Close
...
Loop
Remove the second Set Maillist = db.OpenRecordset("P086 - Email OOR").
I'm working on VBA to format an email that will have different text based on the values in the CheckReturnReason column in t1stNoticeEmails table.
I'm trying to format it so that if the specific reason is only listed once in the table, the email is formatted a specific way with a table displayed inside of it, and if a reason is listed more than once, a spreadsheet is attached with the information. This is how the code currently looks, which does not include anything addressing the Excel attachment for multiple entries.
How would I include different formatting if rst2.RecordCount > 1?
Sub FirstEmail_DuplicatePayment_ReviewVBA()
Dim rst As DAO.Recordset
Dim olApp As Outlook.Application
Dim objMail As Outlook.MailItem
Dim rst2 As DAO.Recordset
Dim strTableBeg As String
Dim strTableBody As String
Dim strTableEnd As String
Dim strFntNormal As String
Dim strTableHeader As String
Dim strFntEnd As String
Dim CheckNum As String
Dim NameOfRecipient As String
Dim StrSQL1 As String
Dim NameSpaceOutlook As Outlook.Namespace
Dim sAddressText As String
Dim sAddress1 As Variant
Dim sAddress2 As Variant
Dim sAddressCity As Variant
Dim sAddressState As Variant
Dim sAddressZip As Variant
gPARAttachment = "S:\UPAY\Z_NewStructure\..."
'SEND FIRST NOTICE EMAILS'
'------------------'
Set rst2 = CurrentDb.OpenRecordset("select distinct ContactEmails from t1stNoticeEmails WHERE CheckReturnReason = 'DuplicatePayment'")
If rst2.RecordCount = 0 Then 'checks if recordset returns any records and continues if records found and exits if no records found
Exit Sub
End If
rst2.MoveFirst
'Create e-mail item
Set olApp = Outlook.Application
Set objMail = olApp.CreateItem(olMailItem)
'Do Until rst2.EOF
Set olApp = Outlook.Application
Set objMail = olApp.CreateItem(olMailItem)
'Define format for output
strTableBeg = "<table border=1 cellpadding=3 cellspacing=0>"
strTableEnd = "</table>"
strTableHeader = "<font size=3 face='Calibri'><b>" & _
"<tr bgcolor=#4DB84D>" & _
td("CheckNumber") & _
td("PayeeName") & _
td("VendorID") & _
td("DocNo / ERNo / PONo") & _
td("Amount") & _
td("CheckDate") & _
"</tr></b></font>"
strFntNormal = "<font color=black face='Calibri' size=3>"
strFntEnd = "</font>"
Set rst = CurrentDb.OpenRecordset("SELECT * FROM t1stNoticeEmails where ContactEmails='" & rst2!ContactEmails & "' AND CheckReturnReason = 'DuplicatePayment' " _
& "Order by FullName asc")
If rst.RecordCount = 0 Then
rst2.Close
Set rst2 = Nothing
Exit Sub
End If
sAddress1 = rst!OriginalCheckAddress1
sAddress2 = rst!OriginalCheckAddress2
sAddressCity = rst!OriginalCheckCity
sAddressState = rst!OriginalCheckState
sAddressZip = rst!OriginalCheckZip
sAddressText = "<Font face='Calibri'>" _
& "The following check(s) sent to " _
& sAddress1 & " " & sAddress2 & " " & sAddressCity & " " & sAddressState & " " & sAddressZip _
& " have been returned to the University by the payee. <br><br>"
rst.MoveFirst
NameOfRecipient = rst!FullName
CheckNum = rst!CheckNumber
'Build HTML Output for the DataSet
strTableBody = strTableBeg & strFntNormal & strTableHeader
Do Until rst.EOF
strTableBody = _
strTableBody & _
"<tr>" & _
"<TD nowrap>" & rst!CheckNumber & "</TD>" & _
"<TD nowrap>" & rst!FullName & "</TD>" & _
"<TD nowrap>" & rst![VendorID/UIN] & "</TD>" & _
"<TD nowrap>" & rst![DocNo / ERNo / PONo] & "</TD>" & _
"<TD align='right' nowrap>" & Format(rst!AmountDue, "currency") & "</TD>" & _
"<TD nowrap>" & rst!OriginalCheckDate & "</TD>" & _
"</tr>"
rst.MoveNext
Loop
'rst.MoveFirst
strTableBody = strTableBody & strFntEnd & strTableEnd
'rst.Close
'Set rst2 = CurrentDb.OpenRecordset("select distinct ch_email from t_TCard_CH_Email")
'rst2.MoveFirst
Call CaptureDPBodyText
With objMail
'Set body format to HTML
.To = rst2!ContactEmails
.BCC = gDPEmailBCC
.Subject = gDPEmailSubject & " - Check# " & CheckNum & " - " & NameOfRecipient
.BodyFormat = olFormatHTML
.HTMLBody = .HTMLBody
.HTMLBody = .HTMLBody & "<HTML><BODY>" & strFntNormal & sAddressText & strTableBody & " </BODY></HTML>"
.HTMLBody = .HTMLBody & gDPBodySig
.SentOnBehalfOfName = "..."
.Attachments.Add gPARAttachment
.Display
'.Send
End With
rst2.MoveNext
'Loop
rst.Close
Set rst = Nothing
rst2.Close
Set rst2 = Nothing
End Sub`
I have found that RecordCount is not reliable with Access. I use something like rst.BOF=true AND rst.EOF=true to check for no returned records.
To see if more than one record was returned use
rst.MoveNext
if rst.EOF=false then <more than one record>
right after
rst.MoveFirst
essentially checking if reading after the first record got you to the end of the data.
I tried to create table in outlook email by using VBA. I know that we can use Htmlbody with table tab to create table. Something like below code
Sub Test
Set oolApp = CreateObject("Outlook.Application")
Set Email = oolApp.CreateItem(0)
Dim MailBody As String
MailBody = "<table border=1>"
MailBody = MailBody & "<tr><td>" & "aaa" & "</td>" & "<td>" & "bbb" & "</td>" & "<td>" & "bbb" & "</td></tr>"
MailBody = MailBody & "<tr><td>" & "123" & "</td>" & "<td>" & "456" & "</td>" & "<td>" & "789" & "</td></tr>"
MailBody = MailBody & "</table>"
Email.HTMLBody = MailBody
Email.display
End Sub
But I would like to use template table in Table Tool -> Design to make table more beautiful. Is there anyway to do it with VBA code.
You could instead, create the table manually and save as an .oft file.
Option Explicit
Sub ThreeColumnGreenStripeTable
Dim Email as mailitem
Set Email = CreateItemFromTemplate("path to ThreeColumnGreenStripeTable.oft")
Email.display
End Sub
I have a code to send email from excel. All the info is taken from cells. I am trying to make "J4" bold but it says symtex error when I use . Sorry i'm pretty new to VBA so please explain as if i'm a complete noob.
Code is:
Sub SendMassEmail()
Row_Number = 1
Do
DoEvents
Row_Number = Row_Number + 1
Dim Mail_Body_Message As String
Dim Full_Name As String
Dim Twitter_Code As String
Mail_Body_Message = Sheet1.Range("J2") & vbNewLine & Sheet1.Range("J3") & vbNewLine & Sheet1.Range("J4") & vbNewLine & Sheet1.Range("J5") & vbNewLine & Sheet1.Range("J6")
Full_Name = Sheet1.Range("B" & Row_Number)
Twitter_Code = Sheet1.Range("D" & Row_Number)
Mail_Body_Message = Replace(Mail_Body_Message, "replace_name_here", Full_Name)
Mail_Body_Message = Replace(Mail_Body_Message, "promo_code_replace", Twitter_Code)
MsgBox Mail_Body_Message
Call SendTheEmail(Sheet1.Range("A" & Row_Number), "This is the Subject", Mail_Body_Message)
Loop Until Row_Number = 5
MsgBox "**Emails Sent**"
End Sub
The problem here is that the variable Mail_Body_Message is just text. There is no way to indicate when something is bold or a color. You must use HTML in your email to achieve what you want. For example:
Replace
Mail_Body_Message = Sheet1.Range("J2") & vbNewLine & Sheet1.Range("J3") & vbNewLine & Sheet1.Range("J4") & vbNewLine & Sheet1.Range("J5") & vbNewLine & Sheet1.Range("J6")
With
Mail_Body_Message = "<HTML><BODY><font size=3>" & Sheet1.Range("J2") & vbNewLine & Sheet1.Range("J3") & vbNewLine & "<b>" & Sheet1.Range("J4") & "</b>" & vbNewLine & Sheet1.Range("J5") & vbNewLine & Sheet1.Range("J6") & "</font></BODY></HTML>"
There is some more work you need to do. You must set your mail item's body format to olFormatHTML. You must also set the HTMLBody of the message to your variable. Basically, you'll need something like this:
Set MItem = OutlookApp.CreateItem(olMailItem)
With MItem
.To = EmailAddr
.Subject = Subj
.BodyFormat = olFormatHTML
.HTMLBody = Mail_Body_Message
.Send
End With
You can also change the color of text with HTML font tags. For example:
Mail_Body_Message = "<font color='red'>" & VBAVariable & "</font>"