VBA, Insert outlook signature in vba code - excel

I have a vba code which sends automatically emails when a due date is approaching at least 7 seven days from the current date.
The problem is they when the email is sent without my outlook signature.
The code is:
Sub email()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Sheets(1).Select
lRow = Cells(Rows.Count, 4).End(xlUp).Row
For i = 2 To lRow
toDate = Cells(i, 3)
If toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 4) 'gets the recipient from col D
eSubject = "Doukementacion per " & Cells(i, 2) & " Targa " & Cells(i, 5)
eBody = "Pershendetje Adjona" & vbCrLf & vbCrLf & "Perfundo dokumentacionin e nevojshem per " & Cells(i, 2) & " me targa " & Cells(i, 5)
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.Display ' ********* Creates draft emails. Comment this out when you are ready
.Send '********** UN-comment this when you are ready to go live
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 11) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub

What I found helpful was to make it a HTMLBody. so this part:
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.Display ' ********* Creates draft emails. Comment this out when you are ready
.Send '********** UN-comment this when you are ready to go live
End With
would look like
With OutMail
.Display 'ads the signature
.To = toList
.Subject = eSubject
.HTMLBody = eBody & .HTMLBody
'.Display ' ********* Creates draft emails. Comment this out when you are ready
.Send '********** UN-comment this when you are ready to go live
End With
You might need to toggle events, not sure since I haven't tested with events disabled

If you don't have picture in your signature and can use .body , then you can just use this simplest tool in my opinion.
Sub Mail_Workbook_1()
Dim OutApp As Object
Dim Outmail As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Display
End With
Signature = OutMail.body
With OutMail
.Subject = "This is the Subject line"
.Body = strbody & Signature
.Send 'or use .Display
End with
On Error GoTo 0
Set Outmail = Nothing
Set OutApp = Nothing
End Sub
Have a great day

Related

How to add keep text with a HTML signature

Seems that i can't add the text while adding the signature in the same code. Below you may see it:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.body = body
.HTMLbody = sig
That HTMLbody is deleting the body that i have 1 row up in the formula.
I have tryed to modify as i saw in other examples here, but nothing seems to work.Bellow you can see also the whole project.
Can you check and let me know were i have faild?
Sub send_mass_email()
Dim i As Integer
Dim name, email, body, subject, copy, place, business As String
Dim OutApp As Object
Dim OutMail As Object
Dim fsFile As Object
Dim fso As Object
Dim fsFolder As Object
Dim strFolder As String
Dim sig As String
sig = ReadSignature("adi.htm")
HTMLbody = ActiveSheet.TextBoxes("TextBox 1").Text
i = 2
'Loop down name column starting at row 2 column 1
Do While Cells(i, 1).Value <> ""
name = Split(Cells(i, 1).Value, " ")(0) 'extract first name
email = Cells(i, 2).Value
subject = Cells(i, 3).Value
copy = Cells(i, 4).Value
business = Cells(i, 5).Value
answ = MsgBox("what it need to be attach " & Cells(i, 1) & " ?", vbYesNo + vbExclamation, "PSK Check")
If answ <> vbYes Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.HTMLbody = body
.HTMLbody = sig
.display
End With
End If
If answ = vbYes Then
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
If xFileDlg.Show = -1 Then
'replace place holders
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = email
.cc = copy
.subject = subject
.HTMLbody = body & sig
.display
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
'.Send
End With
End If
'reset body text
body = ActiveSheet.TextBoxes("TextBox 1").Text
End If
i = i + 1
Loop
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try replacing these two lines...
.HTMLbody = body
.HTMLbody = sig
with
.HTMLbody = body & sig
By the way, if you want a line break between the body and signature, try the following instead...
.HTMLbody = body & "<br>" & sig

How to stop code from sending email when task is marked completed?

The following code works to send emails 7 days on or before the past due date but in order for it to run, it needs to be assigned to a button within Excel. When the file is opened, I want it to run the code automatically and send emails to those that have upcoming or overdue tasks. It needs to stop sending emails where tasks have been marked "Completed".
Sub eMail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Sheets(1).Select
lRow = Cells(Rows.Count, 5).End(xlUp).Row
Set OutApp = CreateObject("Outlook.Application")
For i = 2 To lRow
If Cells(i, 5) <> "" Then
toDate = Replace(Cells(i, 5), ".", "/")
If Left(Cells(i, 18), 5) <> "Mail" And toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 7)
eSubject = "ACTION ITEM - " & Cells(i, 3) & " is due on " & Cells(i, 5)
eBody = "NOTICE for " & Cells(i, 6) & vbCrLf & vbCrLf & "You have task(s)coming due or ones that are past due. Please complete your tasks as soon as possible, then notify the Quality Administrator when the task is complete."
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.Display
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 9) = "Mail Sent " & Date + Time
End If
End If
Next i
ActiveWorkbook.Save
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub
inside of your loop, put an if statement... fix the cell reference:
For i = 2 To lRow
If Cells(i,1).value <> "Completed" Then 'could also use Not Cells(i,1).value = "Completed"
'all of your regular code
End If
Next i
Edit1:
Update to use your code:
For i = 2 To lRow
If Cells(i,1).value <> "Completed" Then 'OPEN IT HERE
If Cells(i, 5) <> "" Then
toDate = Replace(Cells(i, 5), ".", "/")
If Left(Cells(i, 18), 5) <> "Mail" And toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 7)
eSubject = "ACTION ITEM - " & Cells(i, 3) & " is due on " & Cells(i, 5)
eBody = "NOTICE for " & Cells(i, 6) & vbCrLf & vbCrLf & "You have task(s)coming due or ones that are past due. Please complete your tasks as soon as possible, then notify the Quality Administrator when the task is complete."
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.Display
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 9) = "Mail Sent " & Date + Time
End If
End If
End If 'CLOSE IT HERE
Next i
A second way of doing it, with your existing If statement:
For i = 2 To lRow
If Cells(i, 5) <> "" Or Cells(i,1).value <> "Completed" Then
toDate = Replace(Cells(i, 5), ".", "/")
If Left(Cells(i, 18), 5) <> "Mail" And toDate - Date <= 7 Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
toList = Cells(i, 7)
eSubject = "ACTION ITEM - " & Cells(i, 3) & " is due on " & Cells(i, 5)
eBody = "NOTICE for " & Cells(i, 6) & vbCrLf & vbCrLf & "You have task(s)coming due or ones that are past due. Please complete your tasks as soon as possible, then notify the Quality Administrator when the task is complete."
On Error Resume Next
With OutMail
.To = toList
.CC = ""
.BCC = ""
.Subject = eSubject
.Body = eBody
.bodyformat = 1
'.Display
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Cells(i, 9) = "Mail Sent " & Date + Time
End If
End If
Next i

Sending Excel chart via mail (Outlook)

I found a code that turns a range of cell in Excel to a photo. That photo is delivered by mail. The problem is that when i'm using .Display everything is OK but when i'm using .Send the message sent empty.
Here is the code:
Sub Send_Pt_mail()
Dim OutApp As Object
Dim OutMail As Object
Dim Fname As String
Dim ch As ChartObject
'Prepare screen data file
Set ch = Worksheets("Chart").ChartObjects.Add(Range("Photo2Mail").Left, Range("Photo2Mail").Top, Range("Photo2Mail").Width, Range("Photo2Mail").Height)
'calculating the number of Recipients
iRow = Worksheets("Recipients").Cells(Rows.Count, 1).End(xlUp).Row
Recipients = ""
For i = 2 To iRow
'for each record in Recipients sheet an eMail will be send
If ThisWorkbook.Worksheets("Recipients").Cells(i, 2).Value = ThisWorkbook.Worksheets("Recipients").Cells(2, 7).Value Then
Recipients = Recipients & ThisWorkbook.Worksheets("Recipients").Cells(i, 1) & ";"
End If
Next i
'Prepare mail range as an image
Application.ScreenUpdating = True
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Fname = Environ$("temp") & "Mail_snap" & ".gif"
'select the relevant table (update or new data) and export through Chart to file
'then select the charts in dashboard and export through Chart 18 to file
ch.Chart.ChartWizard Source:=Worksheets("DB").Range("Photo2Mail"), gallery:=xlLine, Title:="New Chart"
' ch.Chart.ChartArea.ClearContents
' ch.Width = 1700
' ch.Height = 900
Chart_Name = ch.Name
Worksheets("DB").Activate
Range("Photo2Mail").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Worksheets("Chart").ChartObjects(Chart_Name).Activate
ActiveChart.Paste
ActiveWorkbook.Worksheets("Chart").ChartObjects(Chart_Name).Chart.Export Filename:=Fname, FilterName:="gif"
S = "<img src=" & Fname & "><br>"
'On Error Resume Next
With OutMail
.To = Recipients
.CC = ""
.BCC = ""
.Subject = ThisWorkbook.Worksheets("Recipients").Cells(3, 4) & " " & Format(Now(), "dd/mm/yyyy")
.Save
.HTMLBody = S
' send
.display
End With
On Error GoTo 0
Kill Fname
ch.Delete
StopMacro:
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = False
If (ActiveWindow.Zoom <> 100) Then
ActiveWindow.Zoom = 100
End If
End Sub
If the mail body is not updated before sending then .GetInspector will act as .Display, except for not displaying. The idea is usually associated with generating default signatures especially when the flash associated with display is annoying.
Sub Send_With_Signature_Demo()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "myaddress#somewhere.com"
.Subject = Format(Now(), "dd/mm/yyyy")
' If you have a default signature
' you should find you need either .GetInspector or .Display
.GetInspector
.Save
.Send
End With
StopMacro:
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Add attachment with varying date in file name to Outlook mail

I have an Excel file named "Home Audio for Planning (28-3-2013).
The date will change every day but the text will be the same.
How do I attach those files to Outlook?
Sub Test()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hello World!"
.Attachments.Add ("C:\Users\Desktop\Today\Home Audio for Planning (28-3-2013).xlsx")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Try below code : strLocation will be generated dynamically. You can just pass this variable to your attachments. File name generated would be like Home Audio for Planning_28-03-2013.xlsx
Sub Test()
Dim strLocation As String
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hello World!"
strLocation = "C:\Users\Desktop\Today\Home Audio for Planning" & Format(Now(), "_DD-MM-YYYY") & ".xlsx"
.Attachments.Add (strLocation)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Easy,
.Attachments.Add ("C:\Users\Desktop\Today\Home Audio for Planning (" & FORMAT(DATE,DD-MM-YYYY)")
Did you try to change the attachemnt name dynamic. For ex;
.Attachments.Add ("C:\Users\Desktop\Today\Home Audio for Planning (" + timeVariable + ").xlsx")
and you can set the time variable before to match the date of the date in the required format.
Cheers
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strSubject As String
Dim StrSub As Integer
Dim AttachCnt As Integer
AttachCnt = Item.Attachments.Count
strSubject = Item.Subject
StrSub = Len(strSubject)
strBody = Item.Body
strBod = InStr(1, UCase(strBody), "ATTACH")
cnsolidateMsg = ""
If strBod <> 0 And AttachCnt = 0 Then
cnsolidateMsg = cnsolidateMsg & "Attachment is Null." & vbNewLine
End If
If StrSub = 0 Then
cnsolidateMsg = cnsolidateMsg & "Subject is Empty." & vbNewLine
End If
If UCase(Trim(strSubject)) = "FW:" Then
cnsolidateMsg = cnsolidateMsg & "Forward mail subject is empty." & vbNewLine
End If
If UCase(Trim(strSubject)) = "RE:" Then
cnsolidateMsg = cnsolidateMsg & "Reply mail subject is empty." & vbNewLine
End If
If cnsolidateMsg <> Empty Then
If MsgBox(cnsolidateMsg & vbNewLine & "Are you sure you want to send the Mail?", vbYesNo + vbQuestion + vbMsgBoxSetForeground, "Check for send mail") = vbNo Then
Cancel = True
End If
End If
End Sub
With OutMail
.To = ""
.BodyFormat = olFormatHTML '---Default
.Attachments.Add ("C:\Users\Desktop\Test.txt")
.Display
End With
If not.BodyFormat = olFormatHTMLfile will be attached in the mail body

Outlook mail body is blank

I have the following to send an email, with a range of cells from my Excel sheet.
The email is sent with the correct Subject and CC.
There is data in that cell range (A:B) but I cannot get anything in the body. It stays blank.
Sub SendEmail()
SendEmail Macro
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Sheets("Test1").Range("F2").Value
.CC = Sheets("Test1").Range("F3").Value
.BCC = ""
.Subject = Sheets("Test1").Range("E1").Text
.Body = Sheets("Test1").Range("A:B")
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
the error trapping you have is hiding the error: 13 - Type Mismatch
you will have to construct the .Body by looping through the values
Here's the code to loop through:
Dim I As Long
Dim LastRowColA As Long
Dim BodyString As String
BodyString = ""
LastRowColA = Sheets("Test1").Range("A65536").End(xlUp).Row
For I = 1 To LastRowColA
BodyString = BodyString & Sheets("Test1").Range("A" & I).Value & vbTab & Sheets("Test1").Range("B" & I).Value & vbCrLf
Next I
.Body = BodyString ' instead of = Sheets("Test1").Range("A:B")
Try changing
Sheets("Test1").Range("E1").Text
to
Sheets("Test1").Range("E1").Value

Resources