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.
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 am having difficulty adding an appointment to a coworkers calendar that they shared with me. The problem appears to be in the calendar reference. My appointments keep adding to their main default calendar while I am trying to add them to a separate shared calendar named "Study Schedule". I am running office 365.
Dim olApp As Outlook.Application
Dim olappt As Outlook.AppointmentItem
Dim bAppOpened As Boolean
Dim myNamespace As Outlook.NameSpace
Dim objRecip As Outlook.Recipient
Dim strName As String
Dim myFolder As Outlook.Folder
Const olAppointmentItem = 1
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Err.Clear
Set olApp = CreateObject("Outlook.Application")
bAppOpened = False ' Outlook was not already running, started it
Else
bAppOpened = True ' Outlook was already running
End If
' On Error GoTo Error_Handler
' Get Study Schedule Folder Location
Set myNamespace = olApp.GetNamespace("MAPI")
Set objRecip = myNamespace.CreateRecipient("John Doe")
objRecip.Resolve
' I believe the problem is in the two lines of code below as I try to reference non default folder (shared from john doe)
Set myFolder = myNamespace.GetSharedDefaultFolder(objRecip, olFolderCalendar)
Set myFolder = myFolder.Folders("Study Schedule")
myFolder.Display
Set olappt = myFolder.Items.Add
'Set olappt = myNewFolder.Items.Add
With olappt
.AllDayEvent = True
.Start = ScheduledDate
.Subject = StudyName
.Body = "Study has been scheduled." & vbCr & _
vbCr & _
"Calendar Assigned: " & myFolder & vbCr & _
"Schedule Entry ID: " & ScheduleEntryID & vbCr & _
"Study Name: " & StudyName & vbCr & _
"Scheduled Date: " & ScheduledDate & vbCr & _
vbCr & _
"Principle Investigator: " & PrincipleInvestigator & vbCr & _
"Order Placed By: " & OrderPlacedBy & vbCr & _
vbCr & _
"Species: " & Spec
ies & vbCr & _
"Strain: " & Strain & vbCr & _
"Sex " & Sex & vbCr & _
"Age: " & Age & vbCr & _
"Weight: " & Weight & " Kg" & vbCr & _
"Quantity : " & Quantity & vbCr & _
vbCr & _
"Study Information: " & StudyDescription & vbCr & _
vbCr & _
"This Event was auto generated from the Scheduling Assistant and In-Vivo Database."
.Location = ""
.Display
' .Save
' .Send
End With
... Rest of Code
Any help is greatly appreciated!
It is likely the shared calendar is at the same level as the default calendar.
' For a folder at the same level as the default calendar
' navigate up then back down
Set myFolder = myNamespace.GetSharedDefaultFolder(objRecip, olFolderCalendar)
Set myFolder = myFolder.Parent.Folders("Study Schedule")
I found a work around. The code I ended up going with is posted Below. Thank you everyone for the rapid responses! I really appreciated the help.
Dim olApp As Outlook.Application
Dim olappt As Outlook.AppointmentItem
Dim bAppOpened As Boolean
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim objPane As Outlook.NavigationPane
Dim objModule As Outlook.CalendarModule
Dim CalFolder As Outlook.Folder
Const olAppointmentItem = 1
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Err.Clear
Set olApp = CreateObject("Outlook.Application")
bAppOpened = False ' Outlook was not already running, started it
Else
bAppOpened = True ' Outlook was already running
End If
' On Error GoTo Error_Handler
On Error GoTo 0
Set objPane = Outlook.Application.ActiveExplorer.NavigationPane
Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
With objModule.NavigationGroups
For g = 1 To .Count
Set objGroup = .Item(g)
For i = 1 To objGroup.NavigationFolders.Count
Set objNavFolder = objGroup.NavigationFolders.Item(i)
If objNavFolder = "Study Schedule" Or objNavFolder = "John Doe - Study Schedule" Then
Set CalFolder = objNavFolder.Folder
MsgBox CalFolder
End If
Next
Next
End With
Set olappt = CalFolder.Items.Add
With olappt
.Display
.AllDayEvent = True
.Start = ScheduledDate
.Subject = StudyName
.Body = "Study has been scheduled." & vbCr & _
vbCr & _
"Schedule Entry ID: " & ScheduleEntryID & vbCr & _
"Study Name: " & StudyName & vbCr & _
"Scheduled Date: " & ScheduledDate & vbCr & _
vbCr & _
"Principle Investigator: " & PrincipleInvestigator & vbCr & _
"Order Placed By: " & OrderPlacedBy & vbCr & _
vbCr & _
"Species: " & Species & vbCr & _
"Strain: " & Strain & vbCr & _
"Sex " & Sex & vbCr & _
"Age: " & Age & vbCr & _
"Weight: " & Weight & " Kg" & vbCr & _
"Quantity : " & Quantity & vbCr & _
vbCr & _
"Study Information: " & StudyDescription & vbCr & _
vbCr & _
"This Event was auto generated from the Scheduling Assistant and In-Vivo Database."
.Location = ""
.Display
' .Save
' .Send
End With
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 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.
I am using the following vba code in outlook to count all the emails in a folder and subfolders. But I want to edit my code so that it only counts the unread emails.
Is there a way I can do this and if so would someone please be able to show me how?
Sub HowManyEmails()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim objFolder2 As MAPIFolder
Dim objFolder3 As MAPIFolder
Dim objFolder4 As MAPIFolder
Dim objFolder5 As MAPIFolder
Dim objFolder6 As MAPIFolder
Dim objFolder7 As MAPIFolder
Dim objFolder8 As MAPIFolder
Dim objFolder9 As MAPIFolder
Dim objFolder10 As MAPIFolder
Dim objFolder11 As MAPIFolder
Dim objFolder12 As MAPIFolder
Dim objFolder13 As MAPIFolder
Dim objFolder14 As MAPIFolder
Dim EmailCount As Integer
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("3PL & HAULAGE")
Set objFolder2 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("ACCOMODATION")
Set objFolder3 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("CORE FLEET & EQUIPMENT")
Set objFolder4 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("LUBRICANTS & OILS")
Set objFolder5 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("MARKETING")
Set objFolder6 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("PLANT EQUIPMENT & TOOLS")
Set objFolder7 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("PROPERTY & REFURBISHMENT")
Set objFolder8 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("SECURITY & SYSTEMS")
Set objFolder9 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("SERVICING & REPAIRS")
Set objFolder10 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("STATIONARY")
Set objFolder11 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("TESTING & CALIBRATING")
Set objFolder12 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("UTILITIES: GAS, FUEL, ELECTRICAL (ENERGY)")
Set objFolder13 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("X-HIRE CRANE HIRE")
Set objFolder14 = objnSpace.Folders("Purchasing").Folders("Inbox").Folders("Suppliers").Folders("X-HIRE PLANT EQUIPMENT")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
EmailCount2 = objFolder2.Items.Count
EmailCount3 = objFolder3.Items.Count
EmailCount4 = objFolder4.Items.Count
EmailCount5 = objFolder5.Items.Count
EmailCount6 = objFolder6.Items.Count
EmailCount7 = objFolder7.Items.Count
EmailCount8 = objFolder8.Items.Count
EmailCount9 = objFolder9.Items.Count
EmailCount10 = objFolder10.Items.Count
EmailCount11 = objFolder11.Items.Count
EmailCount12 = objFolder12.Items.Count
EmailCount13 = objFolder13.Items.Count
EmailCount14 = objFolder14.Items.Count
MsgBox "New Suppliers & New Business Report Sent"
TempFilePath = "\\UKSH000-File06\Purchasing\New_Supplier_Set_Ups_&_Audits\assets\"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "<p style='color:#000;font-family:calibri;font-size:16'>Dear Jason," & vbNewLine & vbNewLine & _
"<br><br>" & "This is your weekly report, for " & "<b>" & "New Suppliers & New Business Introductions" & "</b>" & ", sent to you from NewSuppliers." & vbNewLine & _
"<br>" & "Please see a breakdown of different types of suppliers and new business below:" & vbNewLine & vbNewLine & _
"<br><br><br>" & "3PL & HAULAGE SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount & "</b></font>" & vbNewLine & _
"<br>" & "ACCOMODATION SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount2 & "</b></font>" & vbNewLine & _
"<br>" & "CORE FLEET & EQUIPMENT SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount3 & "</b></font>" & vbNewLine & _
"<br>" & "LUBRICANT & OILS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount4 & "</b></font>" & vbNewLine & _
"<br>" & "MARKETING SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount5 & "</b></font>" & vbNewLine & _
"<br>" & "PLANT EQUIPMENT & TOOLS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount6 & "</b></font>" & vbNewLine & _
"<br>" & "PROPERTY & REFURBISHMENT SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount7 & "</b></font>" & vbNewLine & _
"<br>" & "SECURITY & SYSTEMS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount8 & "</b></font>" & vbNewLine & _
"<br>" & "SERVICING & REPAIRS SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount9 & "</b></font>" & vbNewLine & _
"<br>" & "STATIONARY SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount10 & "</b></font>" & vbNewLine & _
"<br>" & "TESTING & CALIBRATING SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount11 & "</b></font>" & vbNewLine & _
"<br>" & "UTILITIES & ENERGY SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount12 & "</b></font>" & vbNewLine & _
"<br>" & "X-HIRE CRANE SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount13 & "</b></font>" & vbNewLine & _
"<br>" & "X-HIRE PLANT SUPPLIERS: " & " " & "<font size=""4.5"" face=""calibri"" color=""red"">" & "<b>" & EmailCount14 & "</b></font>" & vbNewLine & _
"<br><br><br>" & "If you have any queries please reply to this email, NewSuppliers#Hewden.co.uk." & vbNewLine & vbNewLine & _
"<br><br>" & "Kind Regards," & "</font></p>" & vbNewLine & _
"<p style='color:#000;font-family:calibri;font-size:18'><b>Automated Purchasing Email</font></p></b>" & vbNewLine & _
"<br><br><img src='cid:cover.jpg'" & "width='800' height='64'><br>" & vbNewLine & _
"<img src='cid:subs.jpg'" & "width='274' height='51'>"
With OutMail
.SentOnBehalfOfName = "newsuppliers#hewden.co.uk"
.To = "mark.o'brien#hewden.co.uk"
.CC = ""
.BCC = ""
.Subject = "New Suppliers & New Business Introduction - Weekly Report"
.HtmlBody = strbody
.Attachments.Add TempFilePath & "cover.jpg", olByValue, 0
.Attachments.Add TempFilePath & "subs.jpg", olByValue, 0
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
Dim dateStr As String
Dim myItems As Outlook.Items
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
Set myItems = objFolder.Items
myItems.SetColumns ("ReceivedTime")
' Determine date of each message:
For Each myItem In myItems
dateStr = GetDate(myItem.ReceivedTime)
If Not dict.Exists(dateStr) Then
dict(dateStr) = 0
End If
dict(dateStr) = CLng(dict(dateStr)) + 1
Next myItem
' Output counts per day:
msg = ""
For Each o In dict.Keys
msg = msg & o & ": " & dict(o) & " items" & vbCrLf
Next
Dim fso As Object
Dim fo As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.CreateTextFile("C:\Users\x152833\outlook_log.txt")
fo.Write msg
fo.Close
Set fo = Nothing
Set fso = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
You can use
unreadCount = myItems.Restrict("[Unread] = true").Count
You can also try to read the PR_CONTENT_UNREAD MAPI property (DASL name "http://schemas.microsoft.com/mapi/proptag/0x36030003") using MAPIFolder.PropertyAccessor.GetProperty (the property is not guaranteed to be present). If the property is not present, you can catch the exception and fall back to Items.Restrict, which always works, but is a lot less efficient than PR_CONTENT_UNREAD.
Take a look at the folder with OutlookSpy (I am its author - click IMAPIFolder button) to check if PR_CONTENT_UNREAD property is available in your particular case.
It turned out to be quite easy, all you have to do is iterate through the Items collection of your objfolder objects and check the UnRead property of the items like this:
For Each i In objFolder.items
If (i.UnRead) Then
EmailCount = EmailCount + 1
End If
Next
However, I highly recommend getting rid of all those variables named objFolderxy and EmailCountxy. There is a much better way to do this. Consider the following example:
Sub GetFolderStats()
Dim objOutlook As Object, objnSpace As Object, objFolder As Object
Dim d
Set d = CreateObject("Scripting.Dictionary")
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
Set objFolder = objnSpace.Folders("Mailbox - CENSORED").Folders("Inbox").Folders("Suppliers")
For Each folder In objFolder.Folders
emailcount = 0
For Each i In folder.items
If (i.UnRead) Then
emailcount = emailcount + 1
End If
Next
d.Add folder.Name, emailcount
Next
Set d = Nothing
Set objOutlook = Nothing
Set objnSpace = Nothing
Set objFolder = Nothing
End Sub
Now, you might not need the dictionary at all, just wanted to give you an example how you could iterate through the email folders instead of explicitly specifying their names.
Of course, instead of storing these data in the dictionary, you could create the html markup on-the-fly thus there would be no need to process the dictionary saving a for loop.
Hope I could help...