I have an Excel sheet that I use as a mailing automatism for reports. As it currently is it attaches an actual copy of the excel workbook to the email and send them out. The mailer contains several different people, and they get different report each day. Due to the size of some of the files, I am starting to run into an issue where I cannot sent the emails anymore because they are too big, so I am wanting to switch to sending links to the files instead, and I have hit a wall.
I use Lotus Notes 8.5. The VBA will cycle through a range, and each cell has a list of report delimited by a ",". It takes the list and passes it to the mailer as a string. The mailer takes the string, turns it into an array and splits it out, and then checks to make sure the reports are current. One email could have up to 10 different reports in it. I have tried creating an HTML MIME email to include the links. Here is the code I currently have:
Sub Send_HTML_Email(ByRef Name As String, ByRef Address As String, ByRef Reports As String)
Const ENC_IDENTITY_8BIT = 1729
'Send Lotus Notes email containing links to files on local computer
Dim NSession As Object 'NotesSession
Dim NDatabase As Object 'NotesDatabase
Dim NStream As Object 'NotesStream
Dim NDoc As Object 'NotesDocument
Dim NMIMEBody As Object 'NotesMIMEEntity
Dim SendTo As String
Dim subject As String
Dim HTML As String, HTMLbody As String
Dim Array1() As String
Dim Links As String
Dim gRange As Variant
Dim i As Integer
SendTo = "myEmail#address.com"
subject = "My Subject " & Name & "."
Debug.Print subject
Set NSession = CreateObject("Notes.NotesSession") 'using Lotus Notes Automation Classes (OLE)
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
Set NStream = NSession.CreateStream
Array1 = Split(Reports, ",")
i = 1
HTML = "<html>" & vbLf & _
"<head>" & vbLf & _
"<meta http-equiv=""Content-Type"" content=""text/html; charset=UTF-8"" />" & vbLf & _
"</head>" & vbLf & _
"<body>" & vbLf & _
"<p>" & gRange.Value & "</p>"
For Each gRange In Array1
Select Case gRange
Case "Report name 1"
Reports = "G:\file Location\Report Name 1.xlsx"
Case "Report name 2"
Reports = "G:\file Location\Report Name 2.xlsx"
Case "Report name 3"
Reports = "G:\file Location\Report Name 3.xlsx"
Case "Report name 4"
Reports = "G:\file Location\Report Name 4.xlsx"
Case "Report name 5"
Reports = "G:\file Location\Report Name 5.xlsx"
Case "Report name 6"
Reports = "G:\file Location\Report Name 6.xlsx"
End Select
If Reports <> "" And Format(FileDateTime(Reports), "mm/dd/yyyy") = Format(Now, "mm/dd/yyyy") Then
Select Case gRange
Case "Report name 1"
Links = "G:\file%20Location\Report%20Name%201.xlsx"
Case "Report name 2"
Links = "G:\file%20Location\Report%20Name%202.xlsx"
Case "Report name 3"
Links = "G:\file%20Location\Report%20Name%203.xlsx"
Case "Report name 4"
Links = "G:\file%20Location\Report%20Name%204.xlsx"
Case "Report name 5"
Links = "G:\file%20Location\Report%20Name%205.xlsx"
End Select
If Links <> "" Then
HTMLbodyi = ""<a href='file://" & Links & "'>" & gRange & "</a><br>""
End If
"</body>" & vbLf & _
"</html>"
i = i + 1
End If
Next gRange
NSession.ConvertMime = False 'Don't convert MIME to rich text
Set NDoc = NDatabase.CreateDocument()
With NDoc
.Form = "Memo"
.subject = subject
.SendTo = Split(SendTo, ",")
Set NMIMEBody = .CreateMIMEEntity
NStream.WriteText HTML
NMIMEBody.SetContentFromText NStream, "text/html; charset=UTF-8", ENC_IDENTITY_8BIT
.Send False
.Save True, False, False
End With
NSession.ConvertMime = True 'Restore conversion
Set NDoc = Nothing
Set NSession = Nothing
End Sub
I'm using the Case statement to switch the Report and Links set based on the array from the cell with the different report names in it. One persons cell may only have Report name 1 and Report name 3, while the next person has all of them.
I really appreciate any help I can get!
The emails will send, but they are either blank, or they get to the first HTMLbodyi and only include the initial <a where the link should go and then the rest is blank.
I see a problem with this line:
HTMLbodyi = "<a href='file://" & Links & "></><br>"
The HTML is malformed. It needs to be changed to this:
HTMLbodyi = "<a href='file://" & Links & "'>" & gRange & "</a><br>"
The other problem is that you are setting the HTML line on every iteration of the loop, but what you really want to do is just append the link within the loop. You'll need to break up this code:
HTML = "<html>" & vbLf & _
"<head>" & vbLf & _
"<meta http-equiv=""Content-Type"" content=""text/html; charset=UTF-8"" />" & vbLf & _
"</head>" & vbLf & _
"<body>" & vbLf & _
"<p>" & gRange.Value & "</p>" & _
HTMLbodyi & _
"</body>" & vbLf & _
"</html>"
Set your HTML string to the portion up to the tag before the loop. Then in the loop, append the links. Then finally after the loop, add the </body></html> to the HTML string.
Edit:
Here's the updated code. Follow the HTML variable to see the key changes.
Sub Send_HTML_Email(ByRef Name As String, ByRef Address As String, ByRef Reports As String)
Const ENC_IDENTITY_8BIT = 1729
'Send Lotus Notes email containing links to files on local computer
Dim NSession As Object 'NotesSession
Dim NDatabase As Object 'NotesDatabase
Dim NStream As Object 'NotesStream
Dim NDoc As Object 'NotesDocument
Dim NMIMEBody As Object 'NotesMIMEEntity
Dim SendTo As String
Dim subject As String
Dim HTML As String, HTMLbody As String
Dim Array1() As String
Dim Links As String
Dim gRange As Variant
Dim i As Integer
SendTo = "myEmail#address.com"
subject = "My Subject " & Name & "."
Debug.Print subject
Set NSession = CreateObject("Notes.NotesSession") 'using Lotus Notes Automation Classes (OLE)
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
Set NStream = NSession.CreateStream
Array1 = Split(Reports, ",")
i = 1
HTML = "<html>" & vbLf & _
"<head>" & vbLf & _
"<meta http-equiv=""Content-Type"" content=""text/html; charset=UTF-8"" />" & vbLf & _
"</head>" & vbLf & _
"<body>" & vbLf
For Each gRange In Array1
Select Case gRange
Case "Report name 1"
Reports = "G:\file Location\Report Name 1.xlsx"
Case "Report name 2"
Reports = "G:\file Location\Report Name 2.xlsx"
Case "Report name 3"
Reports = "G:\file Location\Report Name 3.xlsx"
Case "Report name 4"
Reports = "G:\file Location\Report Name 4.xlsx"
Case "Report name 5"
Reports = "G:\file Location\Report Name 5.xlsx"
Case "Report name 6"
Reports = "G:\file Location\Report Name 6.xlsx"
End Select
If Reports <> "" And Format(FileDateTime(Reports), "mm/dd/yyyy") = Format(Now, "mm/dd/yyyy") Then
Select Case gRange
Case "Report name 1"
Links = "G:\file%20Location\Report%20Name%201.xlsx"
Case "Report name 2"
Links = "G:\file%20Location\Report%20Name%202.xlsx"
Case "Report name 3"
Links = "G:\file%20Location\Report%20Name%203.xlsx"
Case "Report name 4"
Links = "G:\file%20Location\Report%20Name%204.xlsx"
Case "Report name 5"
Links = "G:\file%20Location\Report%20Name%205.xlsx"
End Select
If Links <> "" Then
HTML = HTML & ""<p><a href='file://" & Links & "'>" & gRange & "</a></p>""
End If
i = i + 1
End If
Next gRange
HTML = HTML & "</body>" & vbLf & "</html>"
NSession.ConvertMime = False 'Don't convert MIME to rich text
Set NDoc = NDatabase.CreateDocument()
With NDoc
.Form = "Memo"
.subject = subject
.SendTo = Split(SendTo, ",")
Set NMIMEBody = .CreateMIMEEntity
NStream.WriteText HTML
NMIMEBody.SetContentFromText NStream, "text/html; charset=UTF-8", ENC_IDENTITY_8BIT
.Send False
.Save True, False, False
End With
NSession.ConvertMime = True 'Restore conversion
Set NDoc = Nothing
Set NSession = Nothing
End Sub
Related
Thank you for taking the time to try and help me with this project.
I have some vba that sends an email to each recipient on my spreadsheet and includes in the body of the text information from the spreadsheet. This piece of the code works great. Here's the part where I am stuck...
The workbook contains a couple tables that I would like to filter and copy/paste into each email BUT the data from each table needs to be filtered to the data that applies to each recipient.
For example:
The email is being sent to a Regional leader and includes scores for their Region overall.
I have 1 table that includes manager scores which can be filtered by Region and
on a second tab, I have a table for each Region that drills down the scores by type of service.
So for the SouthWest Regional leader, I would like to Filter table 1 to only show managers in the SouthWest Region, copy/paste that table directly into the email and then go to the Service Type tables and copy the SouthWest table and paste into the email.
The final piece I would like to accomplish is to copy the employee level details which reside on a separate tab, to a workbook and attach it to the email. This too would need to be specific to employees within each region.
I don't know if this is possible within my code or if there is a smart way to accomplish it. I appreciate any help or insight you are willing to give! I have attached an example file and below is the email code I am currently using. I also have some code that filters the data based on the region that may or may not be helpful.
Sub SendMailtoRFE()
Dim outapp As New Outlook.Application
Dim outmail As Outlook.Mailitem
Dim wks As Worksheet
Dim i As Integer
Dim sFile1 As String
Dim TempFilePath As String
Environ ("UserProfile")
Set outapp = CreateObject("outlook.application")
sFile1 = "Infographic"
TempFilePath = Environ$("temp") & "Roadside Assistance " 'FIND OUT HOW TO CLEAN UP THE NAME: "Temp" added to file name
ActiveWorkbook.Sheets(sFile1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFilePath & sFile1 & ".pdf"
On Error Resume Next
For i = 3 To wks.Range("A" & Rows.Count).End(xlUp).Row
Set outmail = outapp.CreateItem(olMailItem)
With outmail
.To = wks.Range("C" & i).Value
.Subject = wks.Range("A" & i).Value & " Region Roadside Assistance YTD Communication"
.HTMLBody = "Dear " & wks.Range("C" & i).Value & "," & "<br></br>" & _
"You've shared how important Roadside Assistance is for your personal auto clients. As one of the highest frequency types of losses, success or failure " & _
"here may be seen as a signal of the overall value of the program." & "<br></br><br></br>" & _
"Here are the results for clients in your area who completed a survey. Year to date, the NPS was " & FormatPercent(wks.Range("K" & i).Value, 0) & _
" based on " & wks.Range("H" & i).Value & " total responses." & _
" The overall score for all regions is " & FormatPercent(wks.Range("K12").Value, 0) & "." & "<br></br><br></br>" & _
"Below are a few additional details to help you understand your region's score. " & _
"Please follow up with any questions or concerns." & "<br></br><br></br>" & vbNewLine & _
"**Please note, the table containing MLGA scores shows only the MLGA's where 5 or more survey responses were received.**"
.Attachments.Add (TempFilePath & sFile1 & ".pdf")
.display
End With
On Error GoTo 0
Set outmail = Nothing
Next i
Set outapp = Nothing
End Sub
''Filter Region on the MLGA Tow NPS Score Tab
Sub FilterSouthWest()
Dim wks As Worksheet
Set wks = Sheets("MLGA TOW NPS Score")
With wks.Range("A2:C2")
.AutoFilter Field:=3, Criteria1:="9A"
End With
End Sub
Use .SpecialCells(xlCellTypeVisible) to set the range on the filtered table and copy/paste them into the email using WordEditor. To insert the html text create a temporary file and use .InsertFile, This converts the html formatting into word formatting. You may need to add a wait between the copy/paste action depending on the amount of data.
Option Explicit
Sub SendMailtoRFE()
'sheet names
Const PDF = "Infographic" ' attachment
Const WS_S = "MLGA TOW NPS Score" ' filtered score data
Const WS_R = "Regions" ' names and emails
Const WS_T = "Tables" ' Regions Tables
Dim ws As Worksheet, sPath As String, sPDFname As String
Dim lastrow As Long, i As Long, n As Long
' region code for filter
Dim dictRegions As Object, region
Set dictRegions = CreateObject("Scripting.Dictionary")
With dictRegions
.Add "NorthEast", "6A"
.Add "NorthWest", "7A"
.Add "SouthEast", "8A"
.Add "SouthWest", "9A"
End With
sPath = Environ$("temp") & "\"
sPDFname = sPath & "Roadside Assistance " & PDF & ".pdf"
Sheets(PDF).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPDFname
Dim outapp As Outlook.Application
Dim outmail As Outlook.Mailitem
Dim outInsp As Object, oWordDoc
Dim wsRegion As Worksheet
Dim sRegion As String, sEmailAddr As String, rngScore As Range
Dim Table1 As Range, Table2 As Range, tmpHTML As String
' scores
With Sheets(WS_S)
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
Set rngScore = .Range("A2:G" & lastrow) ' 5 columns
End With
' open outlook
Set outapp = New Outlook.Application
' regions
Set wsRegion = Sheets(WS_R)
lastrow = wsRegion.Cells(wsRegion.Rows.Count, "A").End(xlUp).Row
For i = 3 To lastrow '
sRegion = wsRegion.Range("A" & i).Value
sEmailAddr = wsRegion.Range("C" & i).Value
tmpHTML = HTMLFile(wsRegion, i)
' region
With rngScore
.AutoFilter
.AutoFilter Field:=3, Criteria1:=dictRegions(sRegion) ' filter col C
Set Table1 = .SpecialCells(xlCellTypeVisible)
End With
' Service Type Table
Set Table2 = Sheets(WS_T).ListObjects(sRegion).Range ' Table named same as region
'Debug.Print dictRegions(sRegion), sRegion, Table1.Address, Table2.Address
Set outmail = outapp.CreateItem(olMailItem)
n = n + 1
With outmail
.To = sEmailAddr
.Subject = sRegion & " Region Roadside Assistance YTD Communication"
.Attachments.Add sPDFname
.display
End With
Set outInsp = outmail.GetInspector
Set oWordDoc = outInsp.WordEditor
'Wait 1
With oWordDoc
.Content.Delete
.Paragraphs.Add.Range.InsertFile tmpHTML, Link:=False, Attachment:=False
Table1.Copy
.Paragraphs.Add.Range.Paste
.Paragraphs.Add.Range.Text = vbCrLf ' blank line
'Wait 1
Table2.Copy
.Paragraphs.Add.Range.Paste
'Wait 1
End With
Application.CutCopyMode = False
Set oWordDoc = Nothing
Set outInsp = Nothing
Set outmail = Nothing
' delete temp html file
On Error Resume Next
Kill tmpHTML
On Error GoTo 0
'Wait 1
Next
' end
Sheets(WS_S).AutoFilterMode = False
Set outapp = Nothing
AppActivate Application.Caption ' back to excel
MsgBox n & " Emails created", vbInformation
End Sub
Function HTMLFile(ws As Worksheet, i As Long) As String
Const CSS = "p{font:14px Verdana};h1{font:14px Verdana Bold};"
' template
Dim s As String
s = "<html><style>" & CSS & "</style><h1>Dear #NAME#,</h1>" & _
"<p>You've shared how important Roadside Assistance is for your personal auto clients.<br/>" & vbLf & _
"As one of the highest frequency types of losses, success or failure " & vbLf & _
"here may be seen as a signal of the overall value of the program.</p>" & vbLf & _
"<p>Here are the results for clients in your area who completed a survey.</p> " & vbLf & _
"<li>Year to date, the NPS was <b>#NPS_YTD#</b> " & vbLf & _
"based on <b>#RESPONSES#</b> total responses.</li> " & vbLf & _
"<li>The overall score for all regions is <b>#NPS_ALL#</b>,</li>" & vbLf & _
"<p>Below are a few additional details to help you understand your region's score. " & vbLf & _
"Please follow up with any questions or concerns." & "</p>" & vbNewLine & vbLf & _
"<p><i>**Please note, the table containing MLGA scores shows only the MLGA's where 5 " & vbLf & _
"or more survey responses were received.**</i></p></html>"
s = Replace(s, "#NAME#", ws.Cells(i, "C"))
s = Replace(s, "#NPS_YTD#", FormatPercent(ws.Cells(i, "K"), 0))
s = Replace(s, "#RESPONSES#", ws.Cells(i, "H"))
s = Replace(s, "#NPS_ALL#", FormatPercent(ws.Cells(12, "K"), 0))
Dim ff: ff = FreeFile
HTMLFile = Environ$("temp") & "\" & Format(Now(), "~yyyymmddhhmmss") & ".htm"
Open HTMLFile For Output As #ff
Print #ff, s
Close #ff
End Function
Sub Wait(n As Long)
Dim t As Date
t = DateAdd("s", n, Now())
Do While Now() < t
DoEvents
Loop
End Sub
I have an MS Access report that contains records of clients from one table (including the email address) and linked grouped records from other tables fetched by a Query.
I want to send the content of the report to each client separately in the body of the email (not as an attachment), I am able to get the text put in the body of the email but without the formatting and without the picture in the header.
I used the following code which runs behind a click of a button. I would appreciate if anyone can help with the formatting issue AND if there is a way I can automate sending the emails for my 200+ clients without clicking the button each time (like a loop or something):
Private Sub Command70_Click()
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim appOutlook As Outlook.Application
Dim MailOutlook As Outlook.MailItem
Dim RTFBody
Set appOutlook = CreateObject("Outlook.application")
Set MailOutlook = appOutlook.CreateItem(olMailItem)
DoCmd.OutputTo acOutputReport, "report1", acFormatHTML, "Report.htm", , , , acExportQualityScreen
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile("Report.htm", ForReading, False, TristateTrue)
RTFBody = f.ReadAll
f.Close
With MailOutlook
.To = Me.Email.Value
.CC = "anwarmirza.ridha#gmail.com"
.Subject = Me.CR_Number & " " & Me.English_Name & " Weekly Report"
.HTMLBody = "Dear Supplier" & Chr$(13) & Chr$(13) & _
RTFBody
.Send
End With
Set MailOutlook = Nothing
Set appOutlook = Nothing
End Sub
Since MS Access reports are specialized rich text formats, conversion to HTML is not easily available. You would need to rebuild your report with HTML markup. However, there is another approach.
Consider creating an Outlook email template (.oft) with all needed images, colors, fonts, and other formatting with placeholders such as %...% markers:
Dear %ClientName%:
Thank you for purchase of %product% for %totalsales% on %salesdate%. We appreciate your business of %years% years.
%salestable%
Best wishes,
MyCompany Management
Then, have MS Access loop through a recordset of email details and text for message body to fill in placeholders. Handle any date/current/percent formatting in SQL or VBA. Because you need a group level multi-record summary, run two loops at 1) client level and 2) sales level.
strSQL = "SELECT ClientID, ClientName, ...email details... FROM myClientsTable"
Set clientRST = CurrentDb.OpenRecordset(strSQL)
Do While Not clientRST.EOF
Set MailOutlook = appOutlook.CreateItemFromTemplate("C:\Path\To\ClientEmail.oft")
strSQL = "SELECT Col1, Col2, Col3 ...sales details..." _
& " FROM mySalesTable" _
& " WHERE ClientID = " & clientRST!ClientID
Set salesRST = CurrentDb.OpenRecordSet(strSQL)
' TABLE COLUMNS
strTable = "<table><th>"
For i = 1 to salesRST.Fields.Count
strTable = strTable & "<td>" & salesRST.Fields(i-0).Name & "</td>"
Next i
strTable = strTable & "</th>"
' TABLE ROWS
salesRST.MoveFirst
While Not salesRst.EOF
strTable = strTable & "<tr>"
For i = 1 to salesRST.Fields.Count
strTable = strTable & "<td>" & salesRST.Fields(i-0).Value & "</td>"
Next i
strTable = strTable & "</tr>"
salesRST.MoveNext
Wend
strTable = strTable & "</table>"
salesRST.Close
With MailOutlook
' DYNAMIC RECIPEINT
.To = clientRST!Email
.CC = "anwarmirza.ridha#gmail.com"
' DYNAMIC SUBJECT
.Subject = clientRST!CR_Number & " " & clientRST!English_Name & " Weekly Report"
' REPLACE PLACEHOLDERS
.HTMLBody = Replace(.HTMLBody, "%ClientName%", clientRST!ClientName)
.HTMLBody = Replace(.HTMLBody, "%product%", clientRST!product)
.HTMLBody = Replace(.HTMLBody, "%totalsales%", clientRST!totalsales)
.HTMLBody = Replace(.HTMLBody, "%salesdate%", clientRST!salesdate)
.HTMLBody = Replace(.HTMLBody, "%years%", clientRST!client_years)
' ADD SALES TABLE
.HTMLBody = Replace(.HTMLBody, "%salestable%", strTable)
.Send
End With
Set MailOutlook = Nothing
clientRST.MoveNext
Loop
clientRST.Close
I will be using excel to send emails to my clients requesting certain files from them. I have everything working except for 1 small detail and I do not want to use this until I have that 1 detail figured out.
My email populates almost perfectly, except for the fact that at the end, there is about 3 lines of space between "Regards" and my signature. I'm not sure why this is happening. It shows up like this:
Thank you for your attention in this matter.
Regards,
Signature
Does anyone know how to fix it. My code is listed below:
Sub KYC_FATCA()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim signature As String
Dim AccOpen As String
Dim ConDoc As String
Dim SIP As String
Dim AFS As String
Dim W8 As String
Dim LEI As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
'KYC Account Opening Form
If (Cells(cell.Row, "I").Value) = "No" Then
AccOpen = "<b>KYC Account Opening Form</b> ." & "<br>" & "<br>"
Else
AccOpen = ""
End If
'Constating Document
If (Cells(cell.Row, "J").Value) = "No" Then
ConDoc = "<b>Constating Document</b> - ." & "<br>" & "<br>"
Else
ConDoc = ""
End If
'Statement of Policy and Guidelines (SIP&G)
If (Cells(cell.Row, "L").Value) = "No" Then
SIP = "<b>Statement of Policy and Guidelines (SIP&G)</b> - " & "<br>" & "<br>"
Else
SIP = ""
End If
'Audited Financial Statements (AFS)
If (Cells(cell.Row, "M").Value) = "No" Then
AFS = "<b>Audited Financial Statements (AFS)</b> - ." & "<br>" & "<br>"
Else
AFS = ""
End If
'W-8BEN-E Form
If (Cells(cell.Row, "N").Value) = "No" Then
W8 = "<b>W-8BEN-E Form</b> - " & "<br>" & "<br>"
Else
W8 = ""
End If
'Legal Entity Identifier (LEI)
If (Cells(cell.Row, "O").Value) = "Needed" Then
LEI = "<b>Legal Entity Identifier (LEI)</b> - " & "<br>" & "<br>"
Else
LEI = ""
End If
If cell.Value Like "?*#?*.?*" And _
(Cells(cell.Row, "H").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
End With
signature = OutMail.HTMLbody
On Error Resume Next
With OutMail
.To = cell.Text 'Whatever is in cell G
.cc = Cells(cell.Row, "C").Value
'Testing if statements - The below one works perfect
'If LCase(Cells(cell.Row, "Z").Value) = "" Then
' .cc = Cells(cell.Row, "P").Value
'End If
.Subject = Cells(cell.Row, "A").Value & " - " & "Documentation Request" _
.HTMLbody = "<p style='font-family:calibri;font-size:11pt'>" & "Dear " & Cells(cell.Row, "D").Value & ",<br>" & "<br>" & _
"On behalf of " & Cells(cell.Row, "B").Value & ", please by " & "<b><u>" & Cells(cell.Row, "Q").Text & "</b></u>" & "." & "<br>" & "<br>" & _
AccOpen & _
ConDoc & _
SIP & _
AFS & _
W8 & _
LEI & _
"If you have any questions and/or concerns, please contract your Relationship Manager, " & Cells(cell.Row, "B").Value & "." & "<br>" & "<br>" & _
"Thank you for your attention in this matter." & "<br>" & "<br>" & _
"Regards," & "</p>" & _
signature _
'You can add files also like this
If (Cells(cell.Row, "I").Value) = "No" Then
.Attachments.Add ("C:doc")
End If
.Display 'This will open the message itself. If you'd like to send right away, use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
The problem is this line:
signature = OutMail.HTMLbody
This is a clever way to get the signature, but the default email body has a couple blank lines above the signature, and those are getting included when you concatenate the email.
I would visually check signature in a debugger and see what is in there, and remove the stuff you don't want. A simple example might be:
Function RemoveBlankStuff(ByVal text as string) as string
text = text.Replace("<P></P>","") 'Remove any empty paragraphs
text = text.Replace("<BR>","") 'Remove any line breaks
Return text;
End Function
signature = RemoveBlankStuff(OutMail.HTMLBody);
You will need to modify the above function depending on what you find in signature.
I was doing something similar and running into the same issue.
This should work if you replace this portion of code:
With OutMail
.Display
End With
signature = OutMail.HTMLbody
With the following code - it effectively opens, deletes whitespace, and deletes/discards the e-mail created to get the signature:
'gets default signature from e-mail
With OutMail
'2 = HTMLBody
.BodyFormat = 2
.Display
'deletes blank space present before signature
signature = Replace(OutMail.HTMLBody, "<p class=MsoNormal><o:p> </o:p></p>", "")
'removes entire e-mail contents and then closes with discard
OutMail.HTMLBody = Replace(OutMail.HTMLBody, OutMail.HTMLBody, "")
OutMail.Close 1
End With
Not sure if it makes a difference, but in .HTMLBody, I also start as -
.HTMLBody = .HTMLBody & "Good Afternoon," & "<br>" & "whateveryourtextis" & "Thanks," & "<br><br>" & signature
I created an Macro in MS Outlook for an email. The user inputs an answer to a question which results in a variable storing that data as a string. An email is then generated in HTML with a hyperlink containing that variable. I can't seem to figure out how to concatenate the variable "strTrackingNumber" into the complete hyperlink. Any suggestions?
Option Explicit
Sub TestFile
Dim strTrackingNumber as String
strTrackingNumber = InputBox("Please input the Tracking Number")
Set objMsg = Application.CreateItem(olMailItem)
With objMsg
.To = "mickey.smith#surfer.com"
.CC = ""
.BCC = ""
.Subject = "Forecast"
.Categories = ""
.BodyFormat = olFormatHTML ' send HTML message
.HTMLBody = "<style> body{color:black;font-family:Arial;font-size: 12pt;}" & _
"<HTML><body>Dear Member,<br><br> The following document is ready for your review."<a href= 'http://www.bluewave.com/' & strTrackingNumber>Tracking & strTrackingNumber.</a></body>
.Display
End With
Set objMsg = Nothing
End Sub
Output link should look like this: http://www.bluewave.com/Tracking Number
e.g. http://www.bluewave.com/RA-15-30922
.HTMLBody = "<style> body{color:black;font-family:Arial;font-size: 12pt;} </style>" & _
"<HTML><body>Dear Member,<br><br> " & _
"The following document is ready for your review. " & _
"<a href= 'http://www.bluewave.com/" & strTrackingNumber & "'>Tracking " & _
strTrackingNumber & ".</a></body>"
I am fairly new to VBA and I am trying to understand how it really works.
So currently I have an excel sheet with items that have due dates.I was able to look online and send out emails to certain people with their respective due dates. Each email has a link to the excel file thats on a network drive.
However, now I am required to link to somewhere else where each item has a folder. The trick to this is that there is a directory where each item is placed in this directory. They are all within in 1 folder. The folders have the same name as in the text in the excel sheet.
I was wondering if there is a way to take the text from the cell respective to each item and place it in the hyperlink? So depending on the item and when its due. The hyperlink will change every time so it goes to the specific folder. Here is the example of the structure. Y:\Main Directory\Folder 1 and another one would be Y:\Main Directory\Folder 3. I placed the name of each folder next to each item within the excel sheet. Also the column with the name of each folder is in column "B". How would I go about this? Thank you! Much appreciated!
Here is the code:
Option Explicit
Public Sub CheckAndSendMail()
Dim lRow As Long
Dim lstRow As Long
Dim toDate As Date
Dim toList As String
Dim ccList As String
Dim bccList As String
Dim eSubject As String
Dim EBody As String
Dim vbCrLf As String
Dim ws As Worksheet
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set ws = Sheets(1)
ws.Select
lstRow = WorksheetFunction.Max(3, ws.Cells(Rows.Count, "R").End(xlUp).Row)
For lRow = 3 To lstRow
toDate = CDate(Cells(lRow, "R").Value)
If Left(Cells(lRow, "R"), 4) <> "Mail" And toDate - Date <= 7 Then
vbCrLf = "<br><br>"
toList = Cells(lRow, "F") 'gets the recipient from col F
eSubject = "Text " & Cells(lRow, "C") & " is due on " & Cells(lRow, "R").Value
EBody = "<HTML><BODY>"
EBody = EBody & "Dear " & Cells(lRow, "F").Value & vbCrLf
EBody = EBody & "Text" & Cells(lRow, "C") & vbCrLf
EBody = EBody & "Text" & vbCrLf
EBody = EBody & "Link to the Document:"
EBody = EBody & "<A href='Hyperlink to Document'>Description of Document </A>" & vbCrLf
'Line below is where the hyperlink to the folder directory and the different folder names
EBody = EBody & "Text" & "<A href= 'Link to folder Directory\Variable based on text'>Description </A>"
EBody = EBody & "</BODY></HTML>"
MailData msgSubject:=eSubject, msgBody:=EBody, Sendto:=toList
'Cells(lRow, "W").Value = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column W"
End If
Next lRow
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
Function MailData(msgSubject As String, msgBody As String, Sendto As String, _
Optional CCto As String, Optional BCCto As String, Optional fAttach As String)
Dim app As Object, Itm As Variant
Set app = CreateObject("Outlook.Application")
Set Itm = app.CreateItem(0)
With Itm
.Subject = msgSubject
.To = Sendto
If Not IsMissing(CCto) Then .Cc = CCto
If Len(Trim(BCCto)) > 0 Then
.Bcc = BCCto
End If
.HTMLBody = msgBody
.BodyFormat = 2 '1=Plain text, 2=HTML 3=RichText -- ISSUE: this does not keep HTML formatting -- converts all text
'On Error Resume Next
If Len(Trim(fAttach)) > 0 Then .Attachments.Add (fAttach) ' Must be complete path'and filename if you require an attachment to be included
'Err.Clear
'On Error GoTo 0
.Save ' This property is used when you want to saves mail to the Concept folder
.Display ' This property is used when you want to display before sending
'.Send ' This property is used if you want to send without verification
End With
Set app = Nothing
Set Itm = Nothing
End Function
"Description of Document "