#1
|
|||
|
|||
Incorporating Table from Excel into Email Body
Incorporating Table from Excel into Email Body
Hi Team, I hope this message finds you well. I am currently utilizing a macro to streamline our email process by pulling data from an Excel sheet named "Mail Merge." This macro is functioning smoothly. However, I have an additional requirement. Within the same Excel workbook, we have a Score Sheet containing two tables located at C7:F30. I am looking to copy these tables, including their formatting, based on email ID, and paste them into an MS Word template. The aim is to include these tables in the email body. Could you please advise if this is feasible and offer guidance on how to accomplish it? The current macro I'm using is courtesy of Imnoss Ltd. Code:
Sub EnhancedMailMergeToEmail() ' Macro created by Imnoss Ltd ' Please share freely while retaining attribution ' Last Updated 2021-11-06 ' REFERENCES REQUIRED! ' This Macro requires you to add the following libraries: ' "Microsoft Outlook xx.x Object Library" (replace xx.x with version number) and "Microsoft Scripting Runtime" ' To add them, use the "Tools" menu and select "References". Tick the check boxes next to the two libraries and press OK. ' declare variables Dim outlookApp As Outlook.Application Dim outlookMail As Outlook.MailItem Dim outlookAccount As Outlook.Account Dim fso As FileSystemObject Dim f As Object Dim attachFile As File Dim mm As MailMerge Dim df As MailMergeDataField Dim singleDoc As Document Dim mailBody As String Dim lastRecordNum As Long Dim recordCount As Long Dim sendFlag As Boolean Dim validRowFlag As Boolean Dim tempFileName As String Dim tempFolderName As String Dim fieldName As String Dim inputDate As Date ' identify the mail merge of the active document Set mm = ActiveDocument.MailMerge ' check for the mail merge state being that of a mail merge ready to go If mm.State <> wdMainAndDataSource Then If MsgBox("Mailmerge not set up for active document - cannot perform mailmerge. Macro will exit.", vbOKOnly + vbCritical, "Error") = vbOK Then Exit Sub End If ' set lastRecordNum to the number of the last active record (reached using wdLastRecord mm.DataSource.ActiveRecord = wdLastRecord lastRecordNum = mm.DataSource.ActiveRecord ' if the lastRecordNum is less than 50 we assume some may have been deselected so we count only the active records ' counting more than 50 records takes too long If lastRecordNum < 250 Then mm.DataSource.ActiveRecord = wdFirstRecord recordCount = 0 Do While True ' run through the fields to check if a valid email address is provided in any of the "to", "cc" or "bcc" fields (valid address = contains an "@") ' also detect if the row is marked to be ignored validRowFlag = False For Each df In mm.DataSource.DataFields ' clean up the provided field name by running through the name letter by letter and adding only letters to the variable fieldName fieldName = "" For i = 1 To Len(df.Name) Select Case Asc(LCase(Mid(df.Name, i, 1))) Case 97 To 122 fieldName = fieldName & LCase(Mid(df.Name, i, 1)) End Select Next i Select Case fieldName Case "ignore" Select Case LCase(df.Value) Case "true", "yes", "y", "ignore" validRowFlag = False Exit For End Select Case "to", "cc", "bcc" If InStr(1, df.Value, "@", vbTextCompare) > 0 Then validRowFlag = True End If End Select Next If validRowFlag Then recordCount = recordCount + 1 End If If mm.DataSource.ActiveRecord = lastRecordNum Then Exit Do Else mm.DataSource.ActiveRecord = wdNextRecord End If Loop Else recordCount = lastRecordNum End If If recordCount = 0 Then If MsgBox("Cannot find any active / valid / not to be ignored records. Macro will Exit", vbOKOnly + vbCritical, "Error") = vbOK Then Exit Sub End If ' Give the user an opportunity to abort, and also the option to save the emails in drafts, or send immediately Select Case MsgBox("MailMerge to email will proceed for " & IIf(recordCount < 50, recordCount & " active", recordCount) & " records." _ + Chr(10) + Chr(10) + _ "Click 'Yes' to send the emails immediatly, 'No' to save the emails in draft, and 'Cancel' to abort.", _ vbYesNoCancel + vbDefaultButton2 + vbQuestion, "Send Emails") Case vbCancel Exit Sub Case vbYes sendFlag = True Case Else sendFlag = False End Select ' set variables ' outlookApp is used to control outlook to send an email ' fso is used to read the HTML file with the email content Set outlookApp = New Outlook.Application Set fso = New FileSystemObject ' we need to use a temporary file to store the html generated by mail merge ' fso.GetTempName creates a name with the extension tmp. We remove this ' because image files are stored in a folder with the name without the extension and with "_files" at the end tempFileName = Replace(fso.GetTempName, ".tmp", "") mm.DataSource.ActiveRecord = wdFirstRecord recordCount = 0 ' loop through all the records Do While lastRecordNum > 0 ' run through the fields to check if a valid email address is provided in any of the "to", "cc" or "bcc" fields (valid address = contains an "@") ' also detect if the row is marked to be ignored validRowFlag = False For Each df In mm.DataSource.DataFields ' clean up the provided field name by running through the name letter by letter and adding only letters to the variable fieldName fieldName = "" For i = 1 To Len(df.Name) Select Case Asc(LCase(Mid(df.Name, i, 1))) Case 97 To 122 fieldName = fieldName & LCase(Mid(df.Name, i, 1)) End Select Next i Select Case fieldName Case "ignore" Select Case LCase(df.Value) Case "true", "yes", "y", "ignore" validRowFlag = False Exit For End Select Case "to", "cc", "bcc" If InStr(1, df.Value, "@", vbTextCompare) > 0 Then validRowFlag = True End If End Select Next ' only create an email if there is a valid addressa and the row is not marked as to be ignored If validRowFlag Then ' use mailmerge to create a new document for one record (defined by mm.DataSource.ActiveRecord) mm.Destination = wdSendToNewDocument mm.DataSource.FirstRecord = mm.DataSource.ActiveRecord mm.DataSource.LastRecord = mm.DataSource.ActiveRecord mm.Execute Pause:=False ' save the generated doc as a html file in the temp directory Set singleDoc = ActiveDocument singleDoc.SaveAs2 FileName:=Environ("Temp") & Application.PathSeparator & tempFileName & ".tmp", FileFormat:=wdFormatFilteredHTML singleDoc.Close SaveChanges:=wdDoNotSaveChanges Set singleDoc = Nothing ' read the html from the temp directory using fso mailBody = fso.OpenTextFile(Environ("Temp") & Application.PathSeparator & tempFileName & ".tmp", 1).ReadAll ' create a new email message in outlook Set outlookMail = outlookApp.CreateItem(olMailItem) ''' Set From Email Id here outlookMail.SentOnBehalfOfName = "DACCClaims@versuni.com" ' display the email so that any images display correctly outlookMail.Display ' clear the content of the email and remove all attachments (i.e. clear the signature and any images in the signature) outlookMail.HTMLBody = "" Do While outlookMail.Attachments.Count > 0 outlookMail.Attachments.Remove 1 Loop ' ensure formatting is HTML outlookMail.BodyFormat = olFormatHTML ' if the html contains images, then they will be stored in a directory called ' tempFileName followed by the _files in the local language (e.g. _bestanden in Dutch) ' so we need to find the directory, and the loop through each of the files ' checking to see if the files are included in the email as an image (i.e. as 'src="..."') ' if the image is included then the image is attached to the email as a hidden attachment ' and the image path is updated to point to the attached image ' try and find the temporary folder name which would contain any images tempFolderName = "" For Each f In fso.GetFolder(Environ("Temp")).SubFolders If Left(f.Name, Len(tempFileName) + 1) = tempFileName & "_" Then tempFolderName = f.Name Exit For End If Next ' if the folder has been found, iterate through the files If tempFolderName <> "" Then For Each attachFile In fso.GetFolder(Environ("Temp") & Application.PathSeparator & tempFolderName).Files If InStr(1, mailBody, "src=""" & tempFolderName & "/" & attachFile.Name & """", vbBinaryCompare) > 0 Then outlookMail.Attachments.Add attachFile.Path, 1, 0 mailBody = Replace(mailBody, "src=""" & tempFolderName & "/" & attachFile.Name & """", "src=""cid:" & attachFile.Name & """") End If Next End If ' add the mail body from the html created via mailmerge and updated for the newly attached images outlookMail.HTMLBody = mailBody ' run through all the fields in the mail merge data, when an email field is identified add the data to the appropriate field For Each df In mm.DataSource.DataFields ' first check for the field being populated for the active record (row), only check if there is data provided If Trim(df.Value) <> "" Then ' try matching the field name to accepted field names ' the field name is cleaned up by running through the name letter by letter and adding only letters to the variable fieldName fieldName = "" For i = 1 To Len(df.Name) Select Case Asc(LCase(Mid(df.Name, i, 1))) Case 97 To 122 fieldName = fieldName & LCase(Mid(df.Name, i, 1)) End Select Next i Select Case fieldName Case "to" ' add in the to address or addresses as they are presented in the data, multiple address should be separated by a semicolon outlookMail.To = outlookMail.To & ";" & df.Value Case "cc" ' add in the cc address or addresses as they are presented in the data, multiple address should be separated by a semicolon outlookMail.CC = outlookMail.CC & ";" & df.Value Case "bcc" ' add in the bcc address or addresses as they are presented in the data, multiple address should be separated by a semicolon outlookMail.BCC = outlookMail.BCC & ";" & df.Value Case "subject" ' add in the subject as it is presented in the data outlookMail.Subject = df.Value Case "importance" ' change the importance, accepted input values are "high", "normal", and "low" (not case sensitive) ' if field is not provided, or an incorrect input value is provided, then the default is used ' default is typically "Normal", but may have been changed in Outlook Options. Select Case Trim(LCase(df.Value)) Case "high" outlookMail.Importance = olImportanceHigh Case "normal" outlookMail.Importance = olImportanceNormal Case "low" outlookMail.Importance = olImportanceLow End Select Case "sensitivity" ' change the sensitivity, accepted input values are "confidential", "personal", "private", or "normal" (not case sensitive) ' if field is not provided, or an incorrect input value is provided, then the default is used ' default is typically "Normal", but may have been changed in Outlook Options. Select Case Trim(LCase(df.Value)) Case "confidential" outlookMail.Sensitivity = olConfidential Case "personal" outlookMail.Sensitivity = olPersonal Case "private" outlookMail.Sensitivity = olPrivate Case "normal" outlookMail.Sensitivity = olNormal End Select Case "readreceipt" ' request or do not request a read receipt ' if the field contains a boolean TRUE, or any form of "true"/"yes"/"y" (case insensitive) then request a read receipt ' if the field contains a boolean FALSE, or any form of "false"/"no"/"n" (case insensitive) then do not request a read receipt ' if field is not provided, or an incorrect input value is provided, then the default is used ' default is typically to not request a read receipt, but may have been changed in Outlook Options. Select Case Trim(LCase(df.Value)) Case "true", "yes", "y" outlookMail.ReadReceiptRequested = True Case "false", "no", "n" outlookMail.ReadReceiptRequested = False End Select Case "deliveryreceipt" ' request or do not request a delivery report ' if the field contains a boolean TRUE, or any form of "true"/"yes"/"y" (case insensitive) then request a delivery report ' if the field contains a boolean FALSE, or any form of "false"/"no"/"n" (case insensitive) then do not request a delivery report ' if field is not provided, or an incorrect input value is provided, then the default is used ' default is typically to not request a delivery report, but may have been changed in Outlook Options. Select Case Trim(LCase(df.Value)) Case "true", "yes", "y" outlookMail.OriginatorDeliveryReportRequested = True Case "false", "no", "n" outlookMail.OriginatorDeliveryReportRequested = False End Select Case "deliverytime" ' add in a delivery time (delay delivery) ' checks for the field containin a value or something which looks like a date and/or time ' if a datetime is provided, and that datetime is in the future then the delay is added to that datetime ' if a date is provided, and that date is in the future then the delay is added to midnight at the start of the provided date ' if a time is provided then the next instance of that time will be used to define the delay (so email could be sent "tomorrow" if time already passed) ' if no data, invalid data, or a date/datetime in the past is added then no delivery delay is added If (IsNumeric(df.Value) Or IsDate(df.Value)) Then ' A date passed from an Excel table through mail merge will be formatted in US format ("m/d/yyyy"), but the function CDate ' uses the local format, e.g. ("d/m/yyyy"). CDate is nice enough to recognise (and not error) when fed a date with the day > 12, ' so both "15/1/2021" and "1/15/2021" will produce the correct date output (15 January 2021). ' The next couple of lines test for whether the date is the wrong way round and flips the month and day if needed ' A date is believed to be wrong if both month and day are 12 or lower, if CDate parses the date 1/2/2020 as 1 February 2020 ' and finally if the raw input from Excel is a date string (and not a number, which would be valid) inputDate = CDate(df.Value) If Day(inputDate) <= 12 And Month(inputDate) <= 12 And Month(CDate("1/2/2020")) = 2 And _ InStr(1, df.Value, Format(inputDate, "d/m/yyyy")) = 1 Then inputDate = DateSerial(Year(inputDate), Day(inputDate), Month(inputDate)) + TimeSerial(Hour(inputDate), Minute(inputDate), Second(inputDate)) End If If inputDate < Now() - Date Then ' time only, time is in the past so set time for "tomorrow" outlookMail.DeferredDeliveryTime = Date + 1 + inputDate ElseIf inputDate < 1 Then ' time only, time is in the future so set time for "today" outlookMail.DeferredDeliveryTime = Date + inputDate ElseIf inputDate > Now() Then ' date or datetime in the future outlookMail.DeferredDeliveryTime = inputDate End If Debug.Print df.Value, outlookMail.DeferredDeliveryTime End If Case "account" ' select the account from which the email is to be sent ' the account is identified by its full email address ' to identify the account, the code cycles through all the accounts available and selects a match ' if no data, or a non-matching email address is provided, then the default account is used ' note! not the same as send as - see below For Each outlookAccount In outlookApp.Session.Accounts If outlookAccount.SmtpAddress = df.Value Then outlookMail.SendUsingAccount = outlookAccount Exit For End If Next Case "sendas" ' add in an address to send as or send on behalf of ' only added if a valid email address ' if the account does not have permissions, the email will be created but will be rejected by the Exchange server if sent If InStr(1, df.Value, "@", vbTextCompare) > 0 Then outlookMail.SentOnBehalfOfName = df.Value '' If InStr(1, df.Value, "@", vbTextCompare) > 0 Then outlookMail.SentOnBehalfOfName = "gcs_po@philips.com" Case "replyto" ' add in an address to reply to ' only added if a valid email address If InStr(1, df.Value, "@", vbTextCompare) > 0 Then outlookMail.ReplyRecipients.Add (df.Value) Case "attachment" ' add the attachment outlookMail.Attachments.Add df.Value End Select ' end test for the field names End If ' end check for the data value being blank Next df ' move on to the next record ' check the send flag and send or save If sendFlag Then outlookMail.Send Else outlookMail.Close (olSave) End If Set outlookMail = Nothing Else recordCount = recordCount + 1 ' keep a tally of skipped records using recordCount End If ' end the test for whether a valid address is presented in the data ' test if we have just created a document for the last record, if so we set lastRecordNum to zero to indicate that the loop should end, otherwise go to the next active record If mm.DataSource.ActiveRecord >= lastRecordNum Then lastRecordNum = 0 Else mm.DataSource.ActiveRecord = wdNextRecord End If Loop End Sub Sanket |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
move email based on text in email body | megatronixs | Outlook | 3 | 02-10-2015 10:58 AM |
Format email body-Using Excel VBA to send mail | Claytocb | Excel Programming | 1 | 01-31-2013 11:58 PM |
Incorporating software demos within slide show | maestroc | PowerPoint | 0 | 11-08-2012 12:22 PM |
Outlook not sending body of email | sbertram | Outlook | 0 | 08-30-2012 11:50 AM |
Outlook Export Body Table to Excel | almecum | Outlook | 0 | 08-10-2010 11:28 AM |