Attachment is not sent with CDO gmail or attachment is empty - vba

When I run the following sub, the gmail is sent without the attachment. If I set a variable for the attachment, and alter the .AddAttachment statement to .AddAttachment (FName), an attachment is sent with the email but it is empty. Please help. Here is my code:
Sub SendEmail()
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim Msg As String
Dim iBp As CDO.IBodyPart
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
= "stmpCorpServer"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = _
InputBox("Please enter your email address")
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = _
InputBox("Please enter your password")
.Update
End With
'Set Variables
Msg = "Record Count - " & EmlRcrdCt & vbNewLine & _
"Store Count - " & EmlStrCt & vbNewLine & _
"Record Count for shelf on hand > 6*+1 shelf capacity - " & _
EmlRcrdCtShlf6 & vbNewLine & _
"Record count for shelf on hand > 0 and capacity 0 - " & _
EmlRcrdCtShlf0 & vbNewLine & _
"Record count for quantity of adjustment=0 and adjustment quantity>0 - " & _
EmlRcrdQty0 & vbNewLine & _
"Record count for quantity of adjustment>0 and adjustment quantity=0 - " & _
EmlRcrdCtQtyGrtr0 & vbNewLine & vbNewLine & _
"Attached is a spreadsheet of the 'store' counts and 'shelf on hand' counts." & _
vbNewLine & _
"Please let me know if you have any questions." & vbNewLine & vbNewLine & _
EmlMisStrs & vbNewLine & _
EmlLgVar & vbNewLine
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Set email settings
On Error Resume Next
With iMsg
Set .Configuration = iConf
.To = "MyEmail"
.From = """Julia"" <MyEmail>"
.CC = "MyEmail"
.BCC = ""
.Subject = "CAO results for week ending " & LstDayInWk
.TextBody = Msg
.AddAttachment "C:\CAO\SS CAO we 06072014.xlsx"
.Send
End With
On Error GoTo 0
'Activate Control Sheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
End Sub

Related

Access Form VBA to loop through query and send email to multiple recipients [duplicate]

I wonder whether someone could help me please.
I'm trying to write a script which send multiple emails to addressees on a spreadsheet, with various other pieces of information.
I've started to use a solution from Ron de Bruin (below).
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Src As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set Src = ThisWorkbook.Sheets("List")
On Error GoTo cleanup
Src.Select
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Splunk Access"
.Body = "Hi " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"I have created an account: Production." & _
vbNewLine & vbNewLine & _
"Your username and password for this environment is:" & _
vbNewLine & vbNewLine & _
"Username: " & Cells(cell.Row, "B").Value & _
vbNewLine & _
"Password: " & Cells(cell.Row, "E").Value & _
vbNewLine & vbNewLine & _
"Please log in at your earliest convenience and change your password to a more secure one. " & _
vbNewLine & vbNewLine & _
"You can do this by clicking on your name on the top menu and select ‘Edit Account’." & _
vbNewLine & vbNewLine & _
"You can use this link to get to the log in page for this environment: " & _
vbNewLine & vbNewLine & _
"PROD: right/en-US/account/logout " & _
vbNewLine & vbNewLine & _
"Many thanks and kind regards"
.send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
This script works, but I then receive the 'Outlook' security ,message, which with over 100 recipients, isn't practical to keep pressing "Ok" to send the email.
So following more research I changed:
.send
to
.Display
Application.Wait (Now + TimeValue("0:00:01"))
Application.SendKeys "%"
But the problem I have is that the email is created, but isn't sent. Again not practical to keep pressing "Send" for over 100 users.
I then tried a CDO solution, but I ran into problems with the SMTP address because I'm using my works Microsoft Exchange which I'm not an administrator for, and so don't have any of the SMTP details.
I just wondered whether someone may be able to look a this please, and offer some guidance on how I can create the macro to run automatically.
Many thanks and kind regards
Chris
All,
I managed to get this working with the following:
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Src As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set Src = ThisWorkbook.Sheets("List")
On Error GoTo cleanup
Src.Select
For Each cell In Columns("C").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Access"
.Body = "Hi " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"I have created an account for you" & _
vbNewLine & vbNewLine & _
"Your username and password for this environment is:" & _
vbNewLine & vbNewLine & _
"Username: " & Cells(cell.Row, "B").Value & _
vbNewLine & _
"Password: " & Cells(cell.Row, "E").Value & _
vbNewLine & vbNewLine & _
"Please log in at your earliest convenience and change your password to a more secure one. " & _
vbNewLine & vbNewLine & _
"You can do this by clicking on your name on the top menu and select 'Edit Account'." & _
vbNewLine & vbNewLine & _
"You can use this link to get to the log in page for this environment: " & _
vbNewLine & vbNewLine & _
"PROD: https://right/en-US/account/logout " & _
vbNewLine & vbNewLine & _
"Many thanks and kind regards"
' .send
.Display
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Application.SendKeys "+o"
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
I found through further testing, that a automatic pop up appeared when the 'Send' button was clicked by this command Application.SendKeys "%s", so I added Application.SendKeys "+o2, to automatically click "OK".
Kind regards
Chris
try
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
this is of course using .Send
make sure to turn them back on at end of sub

Add appointment to Someones Elses Shared Outlook Calendar Using VBA in MS Access

I am having difficulty adding an appointment to a coworkers calendar that they shared with me. The problem appears to be in the calendar reference. My appointments keep adding to their main default calendar while I am trying to add them to a separate shared calendar named "Study Schedule". I am running office 365.
Dim olApp As Outlook.Application
Dim olappt As Outlook.AppointmentItem
Dim bAppOpened As Boolean
Dim myNamespace As Outlook.NameSpace
Dim objRecip As Outlook.Recipient
Dim strName As String
Dim myFolder As Outlook.Folder
Const olAppointmentItem = 1
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Err.Clear
Set olApp = CreateObject("Outlook.Application")
bAppOpened = False ' Outlook was not already running, started it
Else
bAppOpened = True ' Outlook was already running
End If
' On Error GoTo Error_Handler
' Get Study Schedule Folder Location
Set myNamespace = olApp.GetNamespace("MAPI")
Set objRecip = myNamespace.CreateRecipient("John Doe")
objRecip.Resolve
' I believe the problem is in the two lines of code below as I try to reference non default folder (shared from john doe)
Set myFolder = myNamespace.GetSharedDefaultFolder(objRecip, olFolderCalendar)
Set myFolder = myFolder.Folders("Study Schedule")
myFolder.Display
Set olappt = myFolder.Items.Add
'Set olappt = myNewFolder.Items.Add
With olappt
.AllDayEvent = True
.Start = ScheduledDate
.Subject = StudyName
.Body = "Study has been scheduled." & vbCr & _
vbCr & _
"Calendar Assigned: " & myFolder & vbCr & _
"Schedule Entry ID: " & ScheduleEntryID & vbCr & _
"Study Name: " & StudyName & vbCr & _
"Scheduled Date: " & ScheduledDate & vbCr & _
vbCr & _
"Principle Investigator: " & PrincipleInvestigator & vbCr & _
"Order Placed By: " & OrderPlacedBy & vbCr & _
vbCr & _
"Species: " & Spec
ies & vbCr & _
"Strain: " & Strain & vbCr & _
"Sex " & Sex & vbCr & _
"Age: " & Age & vbCr & _
"Weight: " & Weight & " Kg" & vbCr & _
"Quantity : " & Quantity & vbCr & _
vbCr & _
"Study Information: " & StudyDescription & vbCr & _
vbCr & _
"This Event was auto generated from the Scheduling Assistant and In-Vivo Database."
.Location = ""
.Display
' .Save
' .Send
End With
... Rest of Code
Any help is greatly appreciated!
It is likely the shared calendar is at the same level as the default calendar.
' For a folder at the same level as the default calendar
' navigate up then back down
Set myFolder = myNamespace.GetSharedDefaultFolder(objRecip, olFolderCalendar)
Set myFolder = myFolder.Parent.Folders("Study Schedule")
I found a work around. The code I ended up going with is posted Below. Thank you everyone for the rapid responses! I really appreciated the help.
Dim olApp As Outlook.Application
Dim olappt As Outlook.AppointmentItem
Dim bAppOpened As Boolean
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim objPane As Outlook.NavigationPane
Dim objModule As Outlook.CalendarModule
Dim CalFolder As Outlook.Folder
Const olAppointmentItem = 1
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Err.Clear
Set olApp = CreateObject("Outlook.Application")
bAppOpened = False ' Outlook was not already running, started it
Else
bAppOpened = True ' Outlook was already running
End If
' On Error GoTo Error_Handler
On Error GoTo 0
Set objPane = Outlook.Application.ActiveExplorer.NavigationPane
Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
With objModule.NavigationGroups
For g = 1 To .Count
Set objGroup = .Item(g)
For i = 1 To objGroup.NavigationFolders.Count
Set objNavFolder = objGroup.NavigationFolders.Item(i)
If objNavFolder = "Study Schedule" Or objNavFolder = "John Doe - Study Schedule" Then
Set CalFolder = objNavFolder.Folder
MsgBox CalFolder
End If
Next
Next
End With
Set olappt = CalFolder.Items.Add
With olappt
.Display
.AllDayEvent = True
.Start = ScheduledDate
.Subject = StudyName
.Body = "Study has been scheduled." & vbCr & _
vbCr & _
"Schedule Entry ID: " & ScheduleEntryID & vbCr & _
"Study Name: " & StudyName & vbCr & _
"Scheduled Date: " & ScheduledDate & vbCr & _
vbCr & _
"Principle Investigator: " & PrincipleInvestigator & vbCr & _
"Order Placed By: " & OrderPlacedBy & vbCr & _
vbCr & _
"Species: " & Species & vbCr & _
"Strain: " & Strain & vbCr & _
"Sex " & Sex & vbCr & _
"Age: " & Age & vbCr & _
"Weight: " & Weight & " Kg" & vbCr & _
"Quantity : " & Quantity & vbCr & _
vbCr & _
"Study Information: " & StudyDescription & vbCr & _
vbCr & _
"This Event was auto generated from the Scheduling Assistant and In-Vivo Database."
.Location = ""
.Display
' .Save
' .Send
End With

Save emails to pdf without notification

I have found this code to download emails and convert them to PDF. It works perfectly but the only question that I have is it possible to remove the save notification and that it saves it automaticly when you trigger the macro?
Below is whole my code:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set MyOlNamespace = Application.GetNamespace("MAPI")
Set MySelectedItem = ActiveExplorer.Selection.Item(1)
Set fso = CreateObject("Scripting.FileSystemObject")
'tmpFileName = FSO.GetSpecialFolder(2)
tmpFileName = "C:\CRM\Postboek\Ongekoppeld"
strRecieved = MySelectedItem.ReceivedByName
strSender = MySelectedItem.SenderName
strDatum = MySelectedItem.ReceivedTime
strDatum = Replace(strDatum, ":", "-")
strDatum = Replace(strDatum, "/", "-")
strName = "email_temp.mht"
tmpFileName = tmpFileName & "\" & strName
MySelectedItem.SaveAs tmpFileName, 10
On Error Resume Next
' If MySelectedItem.BodyFormat <> olFormatHTML Then
' strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
' Else
' strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
'' strFile & "'>" & strFile & "</a>"
' End If
' If MySelectedItem.BodyFormat <> olFormatHTML Then
' MySelectedItem.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & MySelectedItem.Body
' Else
' MySelectedItem.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & MySelectedItem.HTMLBody
' End If
Set wrdApp = GetObject(, "Word.Application")
If Err Then
Set wrdApp = CreateObject("Word.Application")
bStarted = True
End If
On Error GoTo 0
Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFileName, Visible:=False, Format:=7)
Set dlgSaveAs = wrdApp.FileDialog(msoFileDialogSaveAs)
Set fdfs = dlgSaveAs.Filters
i = 0
For Each fdf In fdfs
i = i + 1
If InStr(1, fdf.Extensions, "pdf", vbTextCompare) > 0 Then
Exit For
End If
Next fdf
dlgSaveAs.FilterIndex = i
Set WshShell = CreateObject("WScript.Shell")
'SpecialPath = WshShell.SpecialFolders(16)
SpecialPath = "C:\CRM\Postboek\Ongekoppeld"
msgFileName = MySelectedItem.Subject
msgFileName = Replace(msgFileName, ":", "-")
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Global = True
oRegEx.Pattern = "[\/:*?""<>|]"
'msgFileName = Trim(oRegEx.Replace(msgFileName, ""))
'msgFileName = Trim(oRegEx.Replace(msgFileName, ""))
If Len(strRecieved) = 0 Then
dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strSender & " - " & strDatum
ElseIf Len(strRecieved) > 0 Then
dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strRecieved & " - " & strDatum
End If
'dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strRecieved & " - " & strDatum
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)
If Right(strCurrentFile, 4) <> ".pdf" Then
Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _
vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)
If Response = vbCancel Then
wrdDoc.Close 0
If bStarted Then wrdApp.Quit
Exit Sub
ElseIf Response = vbOK Then
intPos = InStrRev(strCurrentFile, ".")
If intPos > 0 Then
strCurrentFile = Left(strCurrentFile, intPos - 1)
End If
strCurrentFile = strCurrentFile & ".pdf"
End If
End If
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
strCurrentFile, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, _
To:=0, _
Item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=0, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False
End If
Set dlgSaveAs = Nothing
wrdDoc.Close
If bStarted Then wrdApp.Quit
Set MyOlNamespace = Nothing
Set MySelectedItem = Nothing
Set wrdDoc = Nothing
Set wrdApp = Nothing
Set oRegEx = Nothing
End Sub
This part gives the notification to the user if they want to save it and I actually just want it removed:
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)
If Right(strCurrentFile, 4) <> ".pdf" Then
Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _
vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)
If Response = vbCancel Then
wrdDoc.Close 0
If bStarted Then wrdApp.Quit
Exit Sub
ElseIf Response = vbOK Then
intPos = InStrRev(strCurrentFile, ".")
If intPos > 0 Then
strCurrentFile = Left(strCurrentFile, intPos - 1)
End If
strCurrentFile = strCurrentFile & ".pdf"
End If
End If
Here is a screenshot of what I want to be removed:
screenshot
Remove this part:
If Len(strRecieved) = 0 Then
dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strSender & " - " & strDatum
ElseIf Len(strRecieved) > 0 Then
dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strRecieved & " - " & strDatum
End If
'dlgSaveAs.InitialFileName = SpecialPath & "\" & msgFileName & " - " & strRecieved & " - " & strDatum
If dlgSaveAs.Show = -1 Then
strCurrentFile = dlgSaveAs.SelectedItems(1)
If Right(strCurrentFile, 4) <> ".pdf" Then
Response = MsgBox("Sorry, only saving in the pdf-format is supported." & _
vbNewLine & vbNewLine & "Save as pdf instead?", vbInformation + vbOKCancel)
If Response = vbCancel Then
wrdDoc.Close 0
If bStarted Then wrdApp.Quit
Exit Sub
ElseIf Response = vbOK Then
intPos = InStrRev(strCurrentFile, ".")
If intPos > 0 Then
strCurrentFile = Left(strCurrentFile, intPos - 1)
End If
strCurrentFile = strCurrentFile & ".pdf"
End If
End If
Set the file name you want below:
wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
___PUTYOURFILENAMEHERE___, _
ExportFormat:=17, _
OpenAfterExport:=False, _
OptimizeFor:=0, _
Range:=0, _
From:=0, _
To:=0, _
Item:=0, _
IncludeDocProps:=True, _
KeepIRM:=True, _
CreateBookmarks:=0, _
DocStructureTags:=True, _
BitmapMissingFonts:=True, _
UseISO19005_1:=False

VBA - Loop, Catch error, assign variable and continue looping?

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 ;)

Changing colour of text in VBA

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