Managed to get this sending using Excel with SMTP.
When sending one e-mail at a time, the first one has the signature displayed where it should be.
Second e-mail sent has the signature but adds the signature as an attachment.
Third e-mail sent has the signature but adds the signature as an attachment twice, and it will repeat the the cycle adding more signature images as attachments.
TLDR:
1 e-mail sent = 0 attachment
2 e-mails sent = 1 attachment
3 e-mails sent = 2 attachments
I don't want any attached files.
Sub SendMail()
Set MyEmail = CreateObject("CDO.Message")
Path = "C:\Users\Users1\Desktop\Signature\"
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
Dim nDateTime As Date, oDateTime As Date
nDateTime = Now
oDateTime = nDateTime - 3
Dim last_row As Integer
last_row = Application.CountA(sh.Range("A:A"))
For i = 2 To last_row
Set emailConfig = MyEmail.Configuration
With MyEmail
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl")
= redacted
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername")
= redacted
emailConfig.Fields.Update
MyEmail.Configuration.Fields.Update
End With
mail_body_message = sh2.Range("D2")
serial_number = sh.Range("A" & i).Value
mail_body_message = Replace(mail_body_message, "replace_serial_here", serial_number)
Attachment = Path + Filename
signaturelogo = "userSignature.png"
With MyEmail
Attachment = Path + Filename
signaturelogo = "userSignature.png"
Path = "C:\Users\Users1\Desktop\Signature\"
.Subject = "Hello there (HTTPS) Serial: " & serial_number
.From = "redacted"
.To = sh.Range("B" & i).Value
.HTMLBody = mail_body_message
.Attachments.Add Path & signaturelogo, 0
End With
If sh.Range("C" & i).Value <= oDateTime Then
MyEmail.Send
End If
Next i
End Sub
Because you are re-using the same object just attach the logo once at the start.
Option Explicit
Sub SendMyMail()
Const LOGO = "C:\Users\Users1\Desktop\Signature\userSignature.png"
Const DAYS = 3
Const SCHEMA = "http://schemas.microsoft.com/cdo/configuration/"
' configure email
Dim MyEmail As Object
Set MyEmail = CreateObject("CDO.Message")
With MyEmail
With .Configuration.Fields
.Item(SCHEMA & "sendusing") = 2
.Item(SCHEMA & "smtpserver") = "smtp.#.com"
.Item(SCHEMA & "smtpserverport") = 465
.Item(SCHEMA & "smtpauthenticate") = 1
.Item(SCHEMA & "sendusername") = "###"
.Item(SCHEMA & "sendpassword") = "#"
.Item(SCHEMA & "smtpusessl") = 1
.Update
End With
' add logo
.AddAttachment LOGO
End With
Dim sh As Worksheet, sh2 As Worksheet
Dim serialno As String, n As Long, i As Long, last_row As Long
Set sh = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
With sh
last_row = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To last_row
If sh.Range("C" & i).Value <= Now - DAYS Then
serialno = sh.Range("A" & i).Value
With MyEmail
.Subject = "Hello there (HTTPS) Serial: " & serialno
.From = "redacted"
.To = sh.Range("B" & i).Value
.HTMLBody = Replace(sh2.Range("D2"), "replace_serial_here", serialno)
' send
On Error Resume Next
.Send
If Err.Number = 0 Then
n = n + 1
Else
MsgBox Err.Description, vbExclamation, "Error Row " & i
End If
On Error GoTo 0
End With
Else
'Debug.Print "Skipped row " & i & " = " & sh.Range("C" & i)
End If
Next
MsgBox n & " emails sent", vbInformation
End Sub
Ended up removing .Attachments.Add Path & signaturelogo, 0
For .HTMLBody = mail_body_message
Changed to below, (the fix)
.HTMLBody = mail_body_message & " "
I send email to a big list of contacts. I don't want to lose the format of the original email.
I am using this code:
Dim emailad, firstname, pretit, midtit, prebod, bod, postbod As String
Dim n As Integer
n = 1
pretit = Sheets(CurrSh).Range("pretit").Value
midtit = Sheets(CurrSh).Range("midtit").Value
prebod = Sheets(CurrSh).Range("prebod").Value
bod = Sheets(CurrSh).Range("bod").Value
postbod = Sheets(CurrSh).Range("postbod").Value
Dim objMail(1 To 500) As Object
Set objitem = GetCurrentItem()
'********** Send e-mail for each e-mail in the list ***********
Set objMail(n) = CreateObject("Outlook.Application")
While (Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value <> "")
emailad = Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value
firstname = Sheets(CurrSh).Range("firstname_ini").Offset(n, 0).Value
Set objMail(n) = objitem.Forward
objMail(n).To = emailad
objMail(n).Subject = pretit & " " & firstname & midtit & " FWD: " & objitem.Subject
objMail(n).HtmlBody = "<HTML><BODY><FONT FACE='Arial'><FONT SIZE='2'>" & prebod & " " & firstname & "," & "<br>" & bod & "<br>" & postbod & objMail(n).HtmlBody & "</FONT></FONT></BODY></HTML>"
objMail(n).Display
Set objMail(n) = Nothing
n = n + 1
Wend
Theend:
End Sub
The problem is this code is so slow.
The strongest suspect for poor performance in this loop is the creation of a new Outlook.Application object for each iteration of the loop. This shouldn't be necessary. Move the Set ObjApp = CreateObject("Outlook.Application") call to just before the WHILE loop and simply re-use the same reference therein.
Revised for OP based on further comment:
I am going to simplify this code to match what I think you're trying to accomplish. I see no need for the large array of mail objects, as you set them to Nothing after they're Displayed. It seems all you want to do is take the current item and send it to each member of your list, customized with their own name as the subject. In that vein, I'd try this:
Dim emailad, firstname, pretit, midtit, prebod, bod, postbod As String
Dim mailApp
Dim newItem
Dim n As Integer
n = 1
pretit = Sheets(CurrSh).Range("pretit").Value
midtit = Sheets(CurrSh).Range("midtit").Value
prebod = Sheets(CurrSh).Range("prebod").Value
bod = Sheets(CurrSh).Range("bod").Value
postbod = Sheets(CurrSh).Range("postbod").Value
Set objitem = GetCurrentItem()
Set mailApp = CreateObject("Outlook.Application")
'********** Send e-mail for each e-mail in the list ***********
While (Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value <> "")
emailad = Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value
firstname = Sheets(CurrSh).Range("firstname_ini").Offset(n, 0).Value
Set newItem = mailApp.CreateItem(0) ' Create a new Mailitem; olMailItem = 0
newItem.To = emailad
newItem.Subject = pretit & " " & firstname & midtit & " FWD: " & objitem.Subject
newItem.HtmlBody = "<HTML><BODY><FONT FACE='Arial'><FONT SIZE='2'>" & prebod & " " & firstname & "," & "<br>" & bod & "<br>" & postbod & objItem.HtmlBody & "</FONT></FONT></BODY></HTML>"
newItem.Send
n = n + 1
Wend
Beyond this, what portion (specifically) is slow? Sending 60 copies of this message shouldn't take that long. Are you sure your loop is terminating when you expect (with only 60 names), or is the data in your sheet possibly preventing your termination from occurring when you expect, causing it to run indefinitely?
Im sorry about the large amount of code but I've been looking over a number of days now to try and resolve this problem. Basically this code runs in outlook when I start it up. It exports different types of emails from different inbox's where different subject headers exist.
It collects parts of the subject heading and parts of the email body and exports this as text into my excel spreadsheet.
The problem I have is that this code actually works fine, and it use to open an excel spreadsheet in the background and export the information into a new row in the relevant columns. Once it has done this it would automatically save the spreadsheet and close.
Now however for some reason, it will do all of that but will not close the spreadsheet and Excel shows up as a running service in windows task manager. This should not be the case and the spreadsheet should save changes and close automatically.
'On the next line edit the path to the spreadsheet you want to export to
Const WORKBOOK_PATH = "X:\New_Supplier_Set_Ups_&_Audits\Supplier SetUps & Amendments.xls"
'On the next line edit the name of the sheet you want to export to
Const SHEET_NAME = "Validations"
Const SHEET_NAME2 = "BankSetup"
Const SHEET_NAME3 = "CreditChecks"
Const SHEET_NAME4 = "Statistics"
Const MACRO_NAME = "Export Messages to Excel (Rev 7)"
Const xlContinuous As Integer = 1
Const vbBlack As Integer = 0
Const xlThin As Integer = 2
Dim olkMsg As Object, _
olkMsg2 As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
excWks2 As Object, _
excWks3 As Object, _
excWks4 As Object, _
intRow As Integer, _
intRow2 As Integer, _
intRow3 As Integer, _
intRow4 As Integer, _
intExp As Integer, _
intVersion As Integer
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Open(WORKBOOK_PATH)
Set excWks = excWkb.Worksheets(SHEET_NAME)
Set excWks2 = excWkb.Worksheets(SHEET_NAME2)
Set excWks3 = excWkb.Worksheets(SHEET_NAME3)
Set excWks4 = excWkb.Worksheets(SHEET_NAME4)
intRow = excWks.UsedRange.Rows.Count + 1
intRow2 = excWks2.UsedRange.Rows.Count + 1
intRow3 = excWks3.UsedRange.Rows.Count + 1
intRow4 = excWks4.UsedRange.Rows.Count + 1
'Write messages to spreadsheet
Dim ns As Outlook.NameSpace
Dim Items As Outlook.Items
Dim Items2 As Outlook.Items
Dim objAttachments As Outlook.Attachments
Dim objMsg As Outlook.MailItem 'Object
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the MAPI Namespace
Set ns = Application.GetNamespace("MAPI")
' Get the Items for the Inbox in the specified account
Set Items = ns.Folders("New Suppliers").Folders("Inbox").Items
Set Items2 = ns.Folders("Credit Checks").Folders("Inbox").Items
' Start looping through the items
For Each olkMsg In Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.UnRead = True Then
If olkMsg.class = olMail Then
If olkMsg.Subject Like "Accept: (Update) New Supplier Request*" Or olkMsg.Subject Like "Accept: (Approval Required) - New Supplier Request*" Or olkMsg.Subject Like "Reject: (Approval Required) - New Supplier Request*" Or olkMsg.Subject Like "Accept: (IMPORTANT REMINDER!) - New Supplier Request*" Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.ReceivedTime
Dim LResult As String
LResult = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
LResult = Left(LResult, InStrRev(LResult, "#") - 1)
excWks.Cells(intRow, 2) = LResult
excWks.Cells(intRow, 3) = olkMsg.VotingResponse
Dim s As String
s = olkMsg.Subject
Dim indexOfName As Integer
indexOfName = InStr(1, s, "Reference: ")
Dim finalString As String
finalString = Right(s, Len(s) - indexOfName - 10)
excWks.Cells(intRow, 4) = finalString
intRow = intRow + 1
olkMsg.UnRead = False
End If
End If
If olkMsg.class = olMail Then
If olkMsg.Subject Like "Complete: Bank Details Set-Up for New Supplier*" Or olkMsg.Subject Like "Incomplete: Bank Details Set-Up for New Supplier*" Then
'Add a row for each field in the message you want to export
excWks2.Cells(intRow2, 1) = olkMsg.ReceivedTime
Dim LResult2 As String
LResult2 = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
LResult2 = Left(LResult2, InStrRev(LResult2, "#") - 1)
excWks2.Cells(intRow2, 2) = LResult2
excWks2.Cells(intRow2, 3) = olkMsg.VotingResponse
Dim s2 As String
s2 = olkMsg.Subject
Dim indexOfName2 As Integer
indexOfName2 = InStr(1, s2, "Reference: ")
Dim finalString2 As String
finalString2 = Right(s2, Len(s2) - indexOfName2 - 10)
excWks2.Cells(intRow2, 4) = finalString2
intRow2 = intRow2 + 1
olkMsg.UnRead = False
End If
End If
If olkMsg.class = olMail Then
If olkMsg.Subject Like "New Supplier Request - Reference:*" Then
'Add a row for each field in the message you want to export
Dim FSO As Object
Dim FolderPath As String
Set FSO = CreateObject("scripting.filesystemobject")
Dim b4 As String
Dim strNewFolderName As String
If TypeName(olkMsg) = "MailItem" Then
b4 = olkMsg.Body
Dim indexOfNameb As Integer
indexOfNameb = InStr(UCase(b4), UCase("Company name: "))
Dim indexOfNamec As Integer
indexOfNamec = InStr(UCase(b4), UCase("Company number: "))
Dim finalStringb As String
finalStringb = Mid(b4, indexOfNameb, indexOfNamec - indexOfNameb)
LResult336 = Replace(finalStringb, "Company Name: ", "")
Dim LResult21 As String
Dim LResult211 As String
Dim LResult2113 As String
LResult21 = Trim(LResult336)
LResult211 = Replace(LResult21, Chr(10), "")
LResult2113 = Replace(LResult211, Chr(13), "")
excWks4.Cells(intRow4, 2) = Trim(LResult2113)
FolderPath = "\\uksh000-file06\purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113)
If FSO.FolderExists(FolderPath) = False Then
Dim strDir As String
strDir = "\\uksh000-file06\purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113)
If Dir(strDir, vbDirectory) = "" Then
MkDir strDir
FileCopy "X:\New_Supplier_Set_Ups_&_Audits\assets\audit.xls", "X:\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113) & "\audit.xls"
Else
MsgBox "Directory exists."
End If
Else
End If
End If
Dim b5 As String
If TypeName(olkMsg) = "MailItem" Then
b5 = olkMsg.Body
Dim indexOfNameb2 As Integer
indexOfNameb2 = InStr(UCase(b5), UCase("Company Number: "))
Dim indexOfNamec2 As Integer
indexOfNamec2 = InStr(UCase(b5), UCase("VAT Number: "))
Dim finalStringb2 As String
finalStringb2 = Mid(b5, indexOfNameb2, indexOfNamec2 - indexOfNameb2)
LResult3362 = Replace(finalStringb2, "Company Number: ", "")
excWks4.Cells(intRow4, 3) = LResult3362
End If
Dim b6 As String
If TypeName(olkMsg) = "MailItem" Then
b6 = olkMsg.Body
Dim indexOfNameb3 As Integer
indexOfNameb3 = InStr(UCase(b6), UCase("VAT Number: "))
Dim indexOfNamec3 As Integer
indexOfNamec3 = InStr(UCase(b6), UCase("Contact Name: "))
Dim finalStringb3 As String
finalStringb3 = Mid(b6, indexOfNameb3, indexOfNamec3 - indexOfNameb3)
LResult3363 = Replace(finalStringb3, "VAT Number: ", "")
excWks4.Cells(intRow4, 4) = LResult3363
End If
Dim l As String
excWks4.Cells(intRow4, 5) = Trim(excWks4.Cells(intRow4, 5))
l = excWks4.Cells(intRow4, 5).Address
excWks4.Cells(intRow4, 6).FormulaArray = "=IF(ISERROR(INDEX('Up'!$A$1:$G$10004,SMALL(IF(LEFT('Up'!$B$1:$B$10004,5)=LEFT(" & l & ",5),ROW($B$1:$B$10004)),ROW(1:1)),6)),""ZZZ"",INDEX('Up'!$A$1:$G$10004,SMALL(IF(LEFT('Up'!$B$1:$B$10004,5)=LEFT(" & l & ",5),ROW($B$1:$B$10004)),ROW(1:1)),6))"
Dim b7 As String
If TypeName(olkMsg) = "MailItem" Then
b7 = olkMsg.Body
Dim indexOfNameb4 As Integer
indexOfNameb4 = InStr(UCase(b7), UCase("Description of the provisional Supplier:"))
Dim indexOfNamec4 As Integer
indexOfNamec4 = InStr(UCase(b7), UCase("Current Status: "))
Dim finalStringb4 As String
Dim LResult3364 As String
Dim LResult33644 As String
Dim LResult336445 As String
finalStringb4 = Mid(b7, indexOfNameb4, indexOfNamec4 - indexOfNameb4)
LResult3364 = Replace(finalStringb4, "Description of the provisional Supplier:", "")
LResult33644 = Replace(LResult3364, Chr(10), "")
LResult336445 = Replace(LResult33644, Chr(13), "")
Dim TrimString As String
TrimString = Trim(LResult336445)
excWks4.Cells(intRow4, 5) = Trim(TrimString)
End If
Dim b77 As String
If TypeName(olkMsg) = "MailItem" Then
b77 = olkMsg.Body
Dim indexOfNameb47 As Integer
indexOfNameb47 = InStr(UCase(b77), UCase("Contact Number: "))
Dim indexOfNamec47 As Integer
indexOfNamec47 = InStr(UCase(b77), UCase("Contact Email: "))
Dim finalStringb47 As String
Dim LResult33647 As String
Dim LResult336447 As String
Dim LResult3364457 As String
finalStringb47 = Mid(b77, indexOfNameb47, indexOfNamec47 - indexOfNameb47)
LResult33647 = Replace(finalStringb47, "Contact Number: ", "")
LResult336447 = Replace(LResult33647, Chr(10), "")
LResult3364457 = Replace(LResult336447, Chr(13), "")
Dim TrimString7 As String
TrimString7 = Trim(LResult3364457)
excWks4.Cells(intRow4, 11) = Trim(TrimString7)
End If
Dim b777 As String
If TypeName(olkMsg) = "MailItem" Then
b777 = olkMsg.Body
Dim indexOfNameb477 As Integer
indexOfNameb477 = InStr(UCase(b777), UCase("Contact Email: "))
Dim indexOfNamec477 As Integer
indexOfNamec477 = InStr(UCase(b777), UCase("Case Reference: "))
Dim finalStringb477 As String
Dim LResult336477 As String
Dim LResult3364477 As String
Dim LResult33644577 As String
finalStringb477 = Mid(b777, indexOfNameb477, indexOfNamec477 - indexOfNameb477)
LResult336477 = Replace(finalStringb477, "Contact Email: ", "")
LResult3364477 = Replace(LResult336477, Chr(10), "")
LResult33644577 = Replace(LResult3364477, Chr(13), "")
Dim TrimString77 As String
TrimString77 = Trim(LResult33644577)
excWks4.Cells(intRow4, 12) = Trim(TrimString77)
End If
Dim b7777 As String
If TypeName(olkMsg) = "MailItem" Then
b7777 = olkMsg.Body
Dim indexOfNameb4777 As Integer
indexOfNameb4777 = InStr(UCase(b7777), UCase("Requested Payment Term: "))
Dim indexOfNamec4777 As Integer
indexOfNamec4777 = InStr(UCase(b7777), UCase("Description of the provisional Supplier: "))
Dim finalStringb4777 As String
Dim LResult3364777 As String
Dim LResult33644777 As String
Dim LResult336445777 As String
finalStringb4777 = Mid(b7777, indexOfNameb4777, indexOfNamec4777 - indexOfNameb4777)
LResult3364777 = Replace(finalStringb4777, "Requested Payment Term: ", "")
LResult33644777 = Replace(LResult3364777, Chr(10), "")
LResult336445777 = Replace(LResult33644777, Chr(13), "")
Dim TrimString777 As String
TrimString777 = Trim(LResult336445777)
excWks4.Cells(intRow4, 29) = TrimString777
End If
Dim s4 As String
s4 = olkMsg.Subject
Dim indexOfName4 As Integer
indexOfName4 = InStr(1, s4, "Reference: ")
Dim finalString4 As String
finalString4 = Right(s4, Len(s4) - indexOfName2 - 34)
excWks4.Cells(intRow4, 7) = finalString4
excWks4.Cells(intRow4, 9) = "Pending"
excWks4.Cells(intRow4, 10).Formula = "=IF(" & excWks4.Cells(intRow4, 25).Address & "=""Declined"",""Manager has Declined"",IF(" & excWks4.Cells(intRow4, 25).Address & "<>""Yes"",IFERROR(CONCATENATE(""Manager has "" & INDEX(Validations!$C$1:$C$9958,MATCH(" & excWks4.Cells(intRow4, 7).Address & ",Validations!$D$1:$D$9958,0))),IF((TODAY()-" & excWks4.Cells(intRow4, 13).Address & ")>=5,""Approval Is Overdue"",""Approval Is Pending"")),IFERROR(CONCATENATE(""Manager has "" & INDEX(Validations!$C$1:$C$9958,MATCH(" & excWks4.Cells(intRow4, 7).Address & ",Validations!$D$1:$D$9958))),""Approval Overidden"")))"
excWks4.Cells(intRow4, 15) = "Pending"
excWks4.Cells(intRow4, 13) = olkMsg.ReceivedTime
Dim LResult33 As String
LResult33 = Replace(GetSMTPAddress(olkMsg, intVersion), ".", " ")
LResult33 = Left(LResult33, InStrRev(LResult33, "#") - 1)
excWks4.Cells(intRow4, 17) = LResult33
excWks4.Cells(intRow4, 18) = "=IFERROR(INDEX('Depot Data'!$F$1:$F$10004,MATCH(" & excWks4.Cells(intRow4, 17).Address & ",'Depot Data'!$E$1:$E$10004,0)),"""")"
excWks4.Cells(intRow4, 19) = "=IFERROR(INDEX('Depot Data'!$H$1:$H$10004,MATCH(" & excWks4.Cells(intRow4, 17).Address & ",'Depot Data'!$E$1:$E$10004,0)),"""")"
excWks4.Cells(intRow4, 20) = "Yes"
excWks4.Cells(intRow4, 23) = "Attach"
excWks4.Cells(intRow4, 24) = "Audit"
excWks4.Cells(intRow4, 25).Formula = "No"
excWks4.Cells(intRow4, 27) = "=Username()"
excWks4.Cells(intRow4, 28) = "Pending"
excWks4.Cells(intRow4, 31) = "V0000847"
excWks4.Cells(intRow4, 32) = "Action"
excWks4.Cells(intRow4, 33) = 1
excWks4.Cells(intRow4, 33).Interior.ColorIndex = 35
Dim LResult21234 As String
LResult21234 = GetSMTPAddress(olkMsg, intVersion)
excWks4.Cells(intRow4, 34) = "=HYPERLINK(""\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113) & "\log.txt"",""Log"")"
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" & Trim(LResult2113) & "\log.txt", True)
a.WriteLine ("Log for Supplier: " & Trim(LResult2113) & " (Created: " & Date & ")")
a.WriteLine (Date & " - " & Time & " - Request received in NewSuppliers#Hewden.co.uk by " & LResult21234 & ", and added to New Supplier Database")
a.Close
Dim Rng As Object
Set Rng = excWks4.Range("B" & intRow4 & ":AH" & intRow4 & "")
With Rng.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
excWks4.Range("B" & intRow4 & ":AH" & intRow4 & "").WrapText = False
intRow4 = intRow4 + 1
olkMsg.UnRead = False
If IsNumeric(LResult3362) Then
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 New Accounts, " & vbNewLine & vbNewLine & _
"<br><B>F.A.O: Beth Crowe </b>" & vbNewLine & vbNewLine & _
"<br><br>" & "This is an automated email sent to you from New Suppliers. This is a credit refrence request." & vbNewLine & vbNewLine & _
"<br>" & "Please would you be able to perform a credit check on the following new supplier:" & vbNewLine & vbNewLine & _
"<br><br><br>" & "Company Name: " & "<b>" & Trim(LResult2113) & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Company Number: " & "<b>" & Trim(LResult3362) & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Case Reference Number (Purchasing Use Only): " & "<b>" & finalString4 & "</b>" & vbNewLine & vbNewLine & _
"<br><br><br>" & "In the event that you have any enquiries, please keep a note of the case reference number. For any questions please contact NewSuppliers#Hewden.co.uk." & vbNewLine & vbNewLine & _
"<br><br>" & "Kind Regards," & "</font></p>" & vbNewLine & _
"<p style='color:#000;font-family:calibri;font-size:18'><b>Hewden Supply Chain Department</b></font></p>" & 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 = "(Credit Reference) New Supplier Credit Check - Reference: " & finalString4
.Attachments.Add TempFilePath & "cover.jpg", olByValue, 0
.Attachments.Add TempFilePath & "subs.jpg", olByValue, 0
.HtmlBody = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
Else
Dim b9 As String
If TypeName(olkMsg) = "MailItem" Then
b9 = olkMsg.Body
Dim indexOfName9 As Integer
indexOfName9 = InStr(UCase(b9), UCase("Full Name of Tradesman: "))
Dim indexOfNam9 As Integer
indexOfNam9 = InStr(UCase(b9), UCase("D.O.B of Tradesman: "))
Dim finalString9 As String
finalString9 = Mid(b9, indexOfName9, indexOfNam9 - indexOfName9)
LResult3369 = Replace(finalString9, "Full Name of Tradesman: ", "")
End If
Dim b10 As String
If TypeName(olkMsg) = "MailItem" Then
b10 = olkMsg.Body
Dim indexOfName99 As Integer
indexOfName99 = InStr(UCase(b10), UCase("D.O.B of Tradesman: "))
Dim indexOfNam99 As Integer
indexOfNam99 = InStr(UCase(b10), UCase("Address of Tradesman: "))
Dim finalString99 As String
finalString99 = Mid(b10, indexOfName99, indexOfNam99 - indexOfName99)
LResult33699 = Replace(finalString99, "D.O.B of Tradesman: ", "")
End If
Dim b101 As String
If TypeName(olkMsg) = "MailItem" Then
b101 = olkMsg.Body
Dim indexOfName991 As Integer
indexOfName991 = InStr(UCase(b101), UCase("Address of Tradesman: "))
Dim indexOfNam991 As Integer
indexOfNam991 = InStr(UCase(b101), UCase("VAT Number: "))
Dim finalString991 As String
finalString991 = Mid(b101, indexOfName991, indexOfNam991 - indexOfName991)
LResult336991 = Replace(finalString991, "Address of Tradesman: ", "")
End If
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 New Accounts, " & vbNewLine & vbNewLine & _
"<br><B>F.A.O: Beth Crowe </b>" & vbNewLine & vbNewLine & _
"<br><br>" & "This is an automated email sent to you from New Suppliers. This is a credit refrence request." & vbNewLine & vbNewLine & _
"<br>" & "Please would you be able to perform a credit check on the following new supplier:" & vbNewLine & vbNewLine & _
"<br><br><br>" & "Trading Name: " & "<b>" & Trim(LResult2113) & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Full Name of Tradesman: " & "<b>" & LResult3369 & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Tradesman Date of Birth: " & "<b>" & LResult33699 & "</b>" & vbNewLine & vbNewLine & _
"<br>" & "Tradesman Address: " & "<b>" & LResult336991 & "</b>" & vbNewLine & vbNewLine & _
"<br><br>" & "Case Reference Number (Purchasing Use Only): " & "<b>" & finalString4 & "</b>" & vbNewLine & vbNewLine & _
"<br><br><br>" & "In the event that you have any enquiries, please keep a note of the case reference number. For any questions please contact NewSuppliers#Hewden.co.uk." & vbNewLine & vbNewLine & _
"<br><br>" & "Kind Regards," & "</font></p>" & vbNewLine & _
"<p style='color:#000;font-family:calibri;font-size:18'><b>Hewden Supply Chain Department</b></font></p>" & 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 = "(Credit Reference) New Supplier Credit Check - Reference: " & finalString4
.Attachments.Add TempFilePath & "cover.jpg", olByValue, 0
.Attachments.Add TempFilePath & "subs.jpg", olByValue, 0
.HtmlBody = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
End If
End If
End If
End If
Next
I dont see save and close lines in your code. Try something like:
excWks4.Save
excWks4.Close
You may need to declare excWks4 like Workbook istead of Object.
Dim excWks4 as Workbook
This is actually my first time posting on this site - I really appreciate all the help I can get!
I have an Excel sheet that contains
clients emails,
their name,
their check dates and
and their processing date.
I want to send out a reminder email to them daily if their processing date is today. I've been successful in writing the code - but I haven't been able to bold parts of the email (ProcessingDate, CheckDate and Time).
Thank you so much again!
Here is my code:
Sub SendEm()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long, MyDate As Date, Client As String, ProcessingDate As Date, CheckDate As Date, Time As Date, PayrollSpecialist As String
Dim Msg As Variant
lr = Sheets("DataSheet").Cells(Rows.Count, "S").End(xlUp).row
Set Mail_Object = CreateObject("Outlook.Application")
MyDate = Date
For i = 2 To lr
Client = Sheets("DataSheet").Range("S" & i).Value
ProcessingDate = Sheets("DataSheet").Range("B" & i).Value
CheckDate = Sheets("DataSheet").Range("C" & i).Value
Time = Sheets("DataSheet").Range("A" & i).Value
PayrollSpecialist = Sheets("DataSheet").Range("D" & i).Value
If Sheets("DataSheet").Range("B" & i).Value = MyDate Then
Msg = "Dear" & " " & Client
Msg = Msg & Sheets("Email").Range("B2").Value
Msg = Msg & ProcessingDate & " "
Msg = Msg & Sheets("Email").Range("B3").Value
Msg = Msg & CheckDate
Msg = Msg & ". " & Sheets("Email").Range("B4").Value & " "
Msg = Msg & Time
Msg = Msg & " " & Sheets("Email").Range("B5").Value & Sheets("Email").Range("B6").Value & vbNewLine & PayrollSpecialist
With Mail_Object.CreateItem(o)
.Subject = Sheets("Email").Range("A2").Value
.To = Sheets("DataSheet").Range("T" & i).Value
.Body = Msg
'.Send
.display 'disable display and enable send to send automatically
End With
End If
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
You can use
.htmlBody rather than .Body
use html
So to bold ProcessingDate
Msg = Msg & "<b>" & ProcessingDate & "</b> "
For example with your code
Msg = "Dear" & " " & Client
'Msg = Msg & Sheets("Email").Range("B2").Value
Msg = Msg & "<b>" & ProcessingDate & "</b> "
'Msg = Msg & Sheets("Email").Range("B3").Value
Msg = Msg & CheckDate
'Msg = Msg & ". " & Sheets("Email").Range("B4").Value & " "
Msg = Msg & Time
'Msg = Msg & " " & Sheets("Email").Range("B5").Value & Sheets("Email").Range("B6").Value & vbNewLine & PayrollSpecialist
With Mail_Object.CreateItem(o)
.Subject = "tested"
.To = "someone#hotmail.com"
.htmlBody = Msg
'.Send
.display 'disable display and enable send to send automatically
End With