I have this email automation program. I essentially want to create a error catch for RecpName. When RecpName is passed into Lotus Notes and returns an error (due to spelling errors), I want to capture that into a error catch.
I still want the loop to keep going and continue down the list, but tell the user which names it couldn't send emails to.
Here's my code:
Sub Send_HTML_Email()
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 wb As Workbook
Dim ws As Worksheet
Dim lstrow As Long, j As Long
Dim RecpName As String, candiName As String
Dim a As Hyperlink
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Detail")
' Instantiate the Lotus Notes COM's Objects.
lstrow = ws.Range("B" & Rows.Count).End(xlUp).Row
Set NSession = CreateObject("Notes.NotesSession") 'using Lotus Notes Automation Classes (OLE)
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
For j = 3 To lstrow
RecpName = ws.Cells(j, 2).Text
candiName = ws.Cells(j, 1).Text
SendTo = RecpName
subject = wb.Worksheets("Email Settings").Range("B1").Text
Debug.Print subject
Set NStream = NSession.CreateStream
HTMLbody = "<p>" & "Hi " & ws.Cells(j, 2).Text & "," & "</p>" & _
vbCrLf & _
"<p>" & Sheets("Email Settings").Cells(2, 2).Text & vbCrLf & _
Sheets("Detail").Cells(j, 1).Text & "</p>" & vbCrLf & _
"<p>" & Sheets("Email Settings").Cells(3, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(4, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(5, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(6, 2).Text & "</p>" & _
"<p>" & Sheets("Email Settings").Cells(9, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(10, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(11, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(12, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(13, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(14, 2).Text & _
"<br>" & Sheets("Email Settings").Cells(15, 2).Text & "</p>"
HTML = "<html>" & vbLf & _
"<head>" & vbLf & _
"<meta http-equiv=""Content-Type"" content=""text/html; charset=UTF-8""/>" & vbLf & _
"</head>" & vbLf & _
"<body>" & vbLf & _
HTMLbody & _
"</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
Next j
Set NDoc = Nothing
Set NSession = Nothing
MsgBox "The e-mail has successfully been created and distributed", vbInformation
End Sub
Maybe this code can help you:
Sub Send_HTML_Email()
Dim cnt_err As Integer: cnt_err = 1
On Error GoTo ErrorHandler
Const ENC_IDENTITY_8BIT = 1729
' Insert the rest of the code here
MsgBox "The e-mail has successfully been created and distributed", vbInformation
Exit Sub
ErrorHandler:
' Insert code to handle the error, e.g.
wb.Worksheets("SheetToSaveMailsNotSent").Range("A" & cnt) = RecpName
cnt = cnt + 1
' The next instruction will continue the subroutine execution
Resume Next
End Sub
For more help you can go to this link.
HTH ;)
Related
Im using below vba query to generate emails with attachment. However, i do not want the query to generate the details in attachments. Instead, i want the data to be paste in body of the email. Im not sure how to amend it. Please help
Sub Buyer_HU()
Dim c As Range, sh As Worksheet, Ky As Variant, dam As Variant, dict As Object
Dim correo As String, lr As Long, wFile As String
Dim tempData As String '<== Changes here
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = Sheets("Template")
If sh.AutoFilterMode Then sh.AutoFilterMode = False
lr = sh.Range("A" & Rows.Count).End(xlUp).Row
sh.Range("BA:BA").ClearContents
For Each c In sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp))
sh.Range("BA" & c.Row) = c & sh.Range("M" & c.Row) & sh.Range("M" & c.Row)
Next
Set dict = CreateObject("scripting.dictionary")
For Each c In sh.Range("BA2", sh.Range("BA" & Rows.Count).End(xlUp))
dict.Item(c.Value) = sh.Range("M" & c.Row)
Next
For Each Ky In dict.Keys
correo = dict(Ky)
sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky
sh.Range("A1:BA" & lr).AutoFilter Columns("BA").Column, Ky, xlOr, " ", True
'ActiveSheet.Range("$A$1:$BA$2000").AutoFilter 53
Workbooks.Add
sh.AutoFilter.Range.EntireRow.Copy Range("A1")
Dim wcc
wcc = Range("AY1")
Range("BA:BA").ClearContents
Range("BA:BA").ClearContents
Range("AY:AY").ClearContents
Range("M:M").ClearContents
Cells.Select
Selection.Columns.AutoFit
Range("A2").Select
tempData = ActiveSheet.Range("A2").Value '<== Changes here
wFile = ThisWorkbook.Path & "\Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & tempData & ".xlsx" '<== Changes here
ActiveWorkbook.SaveAs wFile
ActiveWorkbook.Close False
Set dam = CreateObject("Outlook.Application").CreateItem(0)
With dam
.SentOnBehalfOfName = wcc
'.Bodyformat = olFormatHTML
.To = correo
.cc = ""
.Subject = "Back orders report " & Format(Now(), "dd.mm.yyyy") & "_" & tempData '<== Changes here
.HTMLBody = "Good Morning," & "<br>" & "<br>" & "Please see attached for today's reports." & "<br>" & "<br>" & "Please use the below coding:" & "<br>" & "<br>" & "07/12/2030 - means call off order" & "<br>" & "06/12/2030 - means shipped and orders can be invoiced off" & "<br>" & "05/12/2030 - means order not received - please resend" & "<br>" & "04/12/2030 - means order cancelled - please cancel off at your end if not already done" & "<br>" & "03/12/2030 - means delivery date not known" & "<br>" & "02/12/2030 - means held, more info required" & "<br>" & "01/12/2030 - means held, price problem" & "<br>" & "<br>" & "All other dates should be ETA?dates (If promise date is unchanged please leave blank)" & "<br>" & "<br>" & "PLEASE REPLY IN FORMAT SENT" & "<br>" & "<br>" & "Backorder Report - Please Return by 12pm." & "<br>" & "<br>" & "Thanks and Regards," & "<br>" & "Currys B2B Planning Team"
.Attachments.Add wFile
.Display 'use .Send to send
End With
Next Ky
'sh.ShowAllData
'Selection.AutoFilter
Columns("BA:BA").Select
Selection.Delete Shift:=xlToLeft
MsgBox "Emails generated"
Range("A2").Select
End Sub
I am trying to modify some code to retrieve any links in powerpoint slides and print them to a document. I am struggling to get the objects.
Here is what I have already:
Sub LinkCounter()
Dim FileNum As Integer
Dim oFile As String
Dim textLink() As Shape, i As Long
FileNum = FreeFile()
oFile = ActivePresentation.Path & "\LinksReport.txt"
If Dir(oFile, vbNormal) <> vbNullString Then
Kill oFile
End If
i = 0
p = 1
Open oFile For Append As #FileNum
Print #FileNum, "Links counted on slides"
For Each Slide In ActivePresentation.Slides
Print #FileNum, "Slide"; p
p = p + 1
For Each Hyperlinks.Address In Slide.Hyperlinks
Set textLink(i) = Hyperlinks.Address
Print #FileNum, textLink(i)
i = i + 1
Next Hyperlinks.Address
Next Slide
Close FileNum
End Sub
Any help would be appreciated!
After some deeper searching I found a piece of code that achieves this, it would be good to know where I went wrong however, I'm guessing I need to loop through shapes to find the links?
Sub PPHyperlinkReport()
Dim oSl As Slide
Dim oHl As Hyperlink
Dim sReport As String
Dim iFileNum As Integer
Dim sFileName As String
For Each oSl In ActivePresentation.Slides
For Each oHl In oSl.Hyperlinks
If oHl.Type = msoHyperlinkShape Then
If oHl.Address <> "" Then
sReport = sReport & "HYPERLINK IN SHAPE" _
& vbCrLf _
& "Slide: " & vbTab & oSl.SlideIndex _
& vbCrLf _
& "Shape: " & vbTab & oHl.Parent.Parent.Name _
& vbCrLf _
& "Text: """ & oHl.Parent.Parent.TextFrame.TextRange.Text & """" _
& vbCrLf _
& "External link address:" & vbTab & oHl.Address & vbCrLf & vbNewLine & vbNewLine
Else
sReport = sReport & ""
End If
Else
If oHl.Address <> "" Then
sReport = sReport & "HYPERLINK IN TEXT" _
& vbCrLf _
& "Slide: " & vbTab & oSl.SlideIndex _
& vbCrLf _
& "Shape: " & vbTab & oHl.Parent.Parent.Parent.Parent.Name _
& vbCrLf _
& "Text: """ & oHl.Parent.Parent.Text & """" _
& vbCrLf _
& "External link address:" & vbTab & oHl.Address & vbCrLf & vbNewLine & vbNewLine
Else
sReport = sReport & ""
End If
End If
Next ' hyperlink
Next ' Slide
iFileNum = FreeFile()
sFileName = ActivePresentation.Path & "\AuthorTec_Edits.txt"
Open sFileName For Output As iFileNum
Print #iFileNum, sReport
Close #iFileNum
Call Shell("NOTEPAD.EXE " & sFileName, vbNormalFocus)
End Sub
Is it possible to open an existing application window?
What I want:
What is the code in order to put focus on an already open, but not in focus, application. For example, with:
Set objIE = New InternetExplorer
but I want the macro to put focus on an already existing IE.
Here is another case, I let Lotus notes create an email with the following code:
Sub Email_Bot()
'variables are defined
Dim Maildb As Object
Dim UserName As String
Dim MailDbName As String
Dim MailDoc As Object
Dim Session As Object
Dim AttachME As Object
Dim EmbedObj As Object
Dim Attachment As String
Dim stAttachment As String
Dim Mail_Form As String
Dim Mail_SendTo As String
Dim Mail_Subject As String
Dim Mail_Body As String
Dim Mail_Attachement As Boolean
Dim Mail_Save As Boolean
Dim Mail_Send As Boolean
Dim Mail_Name As String
Dim Mail_Text_1 As String
Dim Mail_Text_2 As String
Dim Mail_Text_3 As String
Dim Mail_Text_4 As String
Dim Mail_Text_5 As String
Dim Mail_Text_6 As String
Dim Mail_Closing As String
Dim Mail_SendBy As String
Dim tb_Mailing_List As Object
Dim tb_Email_Template As Object
Dim LastRow As Integer
Dim Row_Count As Integer
Dim Mail_Body_Lock As Boolean
Dim Workspace As Object
Const EMBED_ATTACHMENT As Long = 1454
'worksheets are defined
Set tb_Mailing_List = ThisWorkbook.Sheets("Mailing List")
Set tb_Email_Template = ThisWorkbook.Sheets("Email Template")
'mail session is defined
Set Session = CreateObject("Notes.NotesSession")
Set Maildb = Session.CURRENTDATABASE
Set MailDoc = Maildb.CREATEDOCUMENT
Set Workspace = CreateObject("Notes.NOTESUIWORKSPACE")
'important variables are set
LastRow = tb_Mailing_List.Cells(Rows.Count, 2).End(xlUp).Row
Row_Count = 3
Mail_Body_Lock = False
'cell assignment
Mail_Text_1 = tb_Email_Template.Cells(4, 4).Value
Mail_Text_2 = tb_Email_Template.Cells(5, 4).Value
Mail_Text_3 = tb_Email_Template.Cells(6, 4).Value
Mail_Text_4 = tb_Email_Template.Cells(7, 4).Value
Mail_Text_5 = tb_Email_Template.Cells(8, 4).Value
Mail_Text_6 = tb_Email_Template.Cells(9, 4).Value
Mail_Closing = tb_Email_Template.Cells(25, 4).Value
Mail_SendBy = tb_Email_Template.Cells(12, 4).Value & vbNewLine & vbNewLine & tb_Email_Template.Cells(13, 4).Value & vbNewLine & tb_Email_Template.Cells(14, 4).Value & vbNewLine & tb_Email_Template.Cells(15, 4).Value & vbNewLine & vbNewLine & tb_Email_Template.Cells(16, 4).Value & vbNewLine & tb_Email_Template.Cells(17, 4).Value & vbNewLine & tb_Email_Template.Cells(18, 4).Value & vbNewLine & tb_Email_Template.Cells(19, 4).Value & vbNewLine & tb_Email_Template.Cells(20, 4).Value & vbNewLine & tb_Email_Template.Cells(21, 4).Value & vbNewLine & tb_Email_Template.Cells(22, 4).Value
'loops until all names have been filled
Do Until Row_Count = LastRow + 1
'Mail Dashboard
Mail_Body_Lock = False
Mail_Send = False
Mail_Form = "Memo"
Mail_Name = tb_Mailing_List.Cells(Row_Count, 2).Value
Mail_SendTo = tb_Mailing_List.Cells(Row_Count, 4).Value
Mail_Subject = tb_Email_Template.Cells(2, 4).Value
Mail_Save = True
'exit round in case the email address is not present
If Mail_SendTo = "" Then GoTo NoEmail
'if only body row 1 has text
If Mail_Text_2 = "" And Mail_Text_3 = "" And Mail_Text_4 = "" And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 and row 2 have text
If Mail_Body_Lock = False And Mail_Text_3 = "" And Mail_Text_4 = "" And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & "," & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 till row 3 have text
If Mail_Body_Lock = False And Mail_Text_4 = "" And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 till row 4 have text
If Mail_Body_Lock = False And Mail_Text_5 = "" And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & Mail_Text_4 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'if only body row 1 till row 5 have text
If Mail_Body_Lock = False And Mail_Text_6 = "" Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & Mail_Text_4 & vbNewLine & Mail_Text_5 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
Mail_Body_Lock = True
End If
'in case there is an error or something
If Mail_Body_Lock = False Then
Mail_Body = "Dear " & Mail_Name & vbNewLine & vbNewLine & Mail_Text_1 & vbNewLine & Mail_Text_2 & vbNewLine & Mail_Text_3 & vbNewLine & Mail_Text_4 & vbNewLine & Mail_Text_5 & vbNewLine & Mail_Text_6 & vbNewLine & vbNewLine & Mail_Closing & vbNewLine & vbNewLine & vbNewLine & Mail_SendBy
End If
'mail build-up
MailDoc.Form = Mail_Form
MailDoc.SendTo = Mail_SendTo
MailDoc.Subject = Mail_Subject
MailDoc.Body = Mail_Body
'attachement build-up
If tb_Email_Template.Cells(28, 4) <> "" And tb_Email_Template.Cells(29, 4) <> "" Then
Attachment = tb_Email_Template.Cells(28, 4)
stAttachment = tb_Email_Template.Cells(29, 4)
Set AttachME = MailDoc.CREATERICHTEXTITEM("stAttachment")
Set EmbedObj = AttachME.EmbedObject(EMBED_ATTACHMENT, "", Attachment, "stAttachment")
End If
Call Workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
MsgBox "Email send?"
NoEmail:
Row_Count = Row_Count + 1
Loop
'variable dump
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set Session = Nothing
Set EmbedObj = Nothing
End Sub
After:
Call Workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
I want to VBA to open that window and not that I have to go there by myself. I am sure that there has to be a way. I used mouse movements, which worked until a colleague with a different screen res. used the program.
I am quite new to VBA and programming and taught myself so I am sorry if this is maybe a dumb question, but I couldn't find the answer so far anywhere else.
Try This way,
Public vPID As Variant
Public Sub OpenApplication()
'Launch application if not already open
If vPID = 0 Then 'Application not already open
101:
vPID = Shell("C:\Windows\system32\notepad.exe", vbNormalFocus)
Else 'Application already open so reactivate
On Error GoTo 101
AppActivate (vPID)
End If
End Sub
Because the variable vPID is stored as a project level Public Variable, its value will be retained for as long as your instance of Excel (or other Microsoft Office application) is open.
I have code in Excel which sends email to a list of recipients:
Sub SendEMail()
Dim xEmail As String
Dim xSubj As String
Dim xMsg As String
Dim xURL As String
Dim i As Integer
Dim k As Double
Dim xCell As Range
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "Send emails to:", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 3 Then
MsgBox "Incorrect number of columns: You have to choose Name, Email address, Account no.!"
Exit Sub
End If
For i = 1 To xRg.Rows.Count
' Get the email address
xEmail = xRg.Cells(i, 2)
' Message subject
xSubj = "Your customer's account is on hold"
' Compose the message
xMsg = ""
xMsg = xMsg & "Dear client" & "," & vbCrLf & vbCrLf
xMsg = xMsg & "We would like to inform you, that Your account has been put on hold - "
xMsg = xMsg & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "If you have any queries, please contact us on uk.ar#bodycote.com." & vbCrLf & vbCrLf
xMsg = xMsg & "Kind regards," & vbCrLf
xMsg = xMsg & "Jon and Martina"
' Replace spaces with %20 (hex)
xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
' Create the URL
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Next
End Sub
I would like to add variable attachments. It will be a pdf file and its name will be the same as the name of customer (which is placed in column A). Basically it should look for "Name.pdf" in "S:\All Team\AX OTI\test\"
The source table looks like:
Please try to use the below code.
xMsg = xMsg & "Dear client" & xRg.Cells(i, 1) & "," & vbCrLf & vbCrLf 'Added the client Name (optional) you can remove it
xMsg = xMsg & "We would like to inform you, that Your account has been put on hold - "
xMsg = xMsg & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
xMsg = xMsg & "If you have any queries, please contact us on uk.ar#bodycote.com." & vbCrLf & vbCrLf
xMsg = xMsg & "Kind regards," & vbCrLf
xMsg = xMsg & "Jon and Martina" & vbCrLf & vbCrLf 'Added two break point
' Replace spaces with %20 (hex)
xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
' Replace carriage returns with %0D%0A (hex)
xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
' Create the URL
xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg &"&attachment=S:\All Team\AX OTI\test\" & Cells(i,1) & ".pdf" 'Changed to this
' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
' Wait two seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Based on #Vityata advice, I've checked the question and based on that, I' ve changed the code. It is tested and works smoothly. The code is much easier, but the job is done.
Sub SendEmail()
Dim Mail_Object, OutApp As Variant
With ActiveSheet
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row 'list of recipients (email address) - it takes as many addresses as B column contains
End With
For i = 2 To lastrow
Set Mail_Object = CreateObject("Outlook.Application")
Set OutApp = Mail_Object.CreateItem(0)
With OutApp
.Subject = "Your customer's account is on hold"
.Body = "Dear client" & "," & vbCrLf & vbCrLf & "We would like to inform you, that Your account has been put on hold." & vbCrLf & vbCrLf & "If you have any queries, please contact us on uk.ar#bodycote.com." & vbCrLf & vbCrLf & "Kind regards," & vbCrLf & "Jon and Martina"
.To = Cells(i, 2).Value
strLocation = "S:\All team\AX OTI\test\" & Cells(i, 1) & ".pdf"
.Attachments.Add (strLocation)
.display
'.send
End With
Next i
debugs:
If Err.Description <> "" Then MsgBox Err.Description
End Sub
Here you have something that works really nicely - Add attachement to outlook with varying file names
In your case, simply copy the code and make sure that in the part strLocation you write something like:
strLocation = "C:\Users\user\Desktop\" & Cells(i,2) & ".pdf"
thus, you will be able to loop around it. In general, take a good look at the mentioned answer, it is really a good approach (IMHO quite better than sending keys).
I need to change the colour of: 'Cells(cell.Row, "A").Value' Cells(cell.Row, "E").Value to blue.
Can you help?
Sub Test1()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Test As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "TITLE" & " - " & Format(Now, "dd_mmmm_yyyy")
.Body = Test & "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Text1" & _
vbNewLine & vbNewLine & _
"Text2'" & Cells(cell.Row, "E").Value & "TEXT" & _
vbNewLine & vbNewLine & _
"TEXT3" & _
vbNewLine & vbNewLine & _
"TEXT4" & _
vbNewLine & vbNewLine & _
"TEXT5" & _
vbNewLine & vbNewLine & "Many thanks," & vbNewLine & vbNewLine & "DCX PMO Team"
'Adding an attachment
.Attachments.Add ("D:\Users\ABOHANNO\Desktop\Digital Transformation\tagging\DCX Sales Process.pptx")
.Send 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Try this:
cell.Resize(1,5).Font.Color = vbBlue