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
Related
I'm trying to send an email to selected recipient(s) based on if a cell in Excel meets specific criteria, in this instance "yes".
The code will only send to the first user in the range that it sees the "yes" criteria being met.
Sub Read_Emails()
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
For Each cell In Columns("N").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "R").Value) = "yes" Then
With objEmail
.To = cell.Value
.CC = ""
.Subject = "Subject here"
.BodyFormat = olFormatHTML
.HTMLBody = "Hello," & "<p>" & "Message here."
.Send
End With
End If
Next cell
Set objEmail = Nothing
Set objOutlook = Nothing
End Sub
I was able to troubleshoot this myself using https://www.rondebruin.nl/win/s1/outlook/bmail5.htm.
Code below for those interested in similar problem:
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("L").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "P").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Subject here"
.Body = "Hello " & Cells(cell.Row, "K").Value & "," _
& vbNewLine & vbNewLine & _
"Message here."
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.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
I am trying to attach a file to outlook using VBA, however my code always seems to attach a blank file.
The code currently saves a workbook in a pre-defined path and then adds a file by the same name as an attachment to outlook but the file attached is blank and I'm not sure why. This "blank" file does not appear to be saved anywhere by the code so not sure where it is coming from.
Dim NewWkb As Workbook
Dim OutApp As Object
Dim OutMail As Object
Dim i As Long
Dim COB As Variant
COB = Range("B16").Value
COB = Format(COB, "DD_MMM_YYYY")
Application.DisplayAlerts = False
Set NewWkb = Workbooks.Add
NewWkb.SaveAs "C:\Users\Documents\BS_Spray " & COB
For i = 2 To ThisWorkbook.Worksheets.Count
ThisWorkbook.Sheets(i).Copy NewWkb.Worksheets(NewWkb.Worksheets.Count)
Next
Sheets("sheet1").Delete
Application.DisplayAlerts = True
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = " "
.Subject = "SL Utility B/S Report " & J
.Body = "Hi all," & vbNewLine & vbNewLine & "Please see attached " & J
.Attachments.Add NewWkb.FullName
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
You should pass "C:\Users\Documents\BS_Spray " & COB to .Attachments.Add
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
I am trying to set up several buttons on an Excel form to email different groups of people.
I made several ranges of cells on a separate worksheet to list the email addresses.
For example, I want "Button A" to open Outlook and put the list of email addresses from "Worksheet B: Cells D3-D6". Then all that has to be done is hit "Send" in Outlook.
Sub Mail_workbook_Outlook_1()
'Working in 2000-2010
'This example send the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object
EmailTo = Worksheets("Selections").Range("D3:D6")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = EmailTo
.CC = "person1#email.com;person2#email.com"
.BCC = ""
.Subject = "RMA #" & Worksheets("RMA").Range("E1")
.Body = "Attached to this email is RMA #" & Worksheets("RMA").Range("E1") & ". Please follow the instructions for your department included in this form."
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error Goto 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You have to loop through every cell in the range "D3:D6" and construct your To string. Simply assigning it to a variant will not solve the purpose. EmailTo becomes an array if you assign the range directly to it. You can do this as well but then you will have to loop through the array to create your To string
CODE
Option Explicit
Sub Mail_workbook_Outlook_1()
'Working in 2000-2010
'This example send the last saved version of the Activeworkbook
Dim OutApp As Object
Dim OutMail As Object
Dim emailRng As Range, cl As Range
Dim sTo As String
Set emailRng = Worksheets("Selections").Range("D3:D6")
For Each cl In emailRng
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sTo
.CC = "person1#email.com;person2#email.com"
.BCC = ""
.Subject = "RMA #" & Worksheets("RMA").Range("E1")
.Body = "Attached to this email is RMA #" & _
Worksheets("RMA").Range("E1") & _
". Please follow the instructions for your department included in this form."
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
ToAddress = "test#test.com"
ToAddress1 = "test1#test.com"
ToAddress2 = "test#test.com"
MessageSubject = "It works!."
Set ol = CreateObject("Outlook.Application")
Set newMail = ol.CreateItem(olMailItem)
newMail.Subject = MessageSubject
newMail.RecipIents.Add(ToAddress)
newMail.RecipIents.Add(ToAddress1)
newMail.RecipIents.Add(ToAddress2)
newMail.Send
Both answers are correct.
If you user .TO -method then the semicolumn is OK - but not for the addrecipients-method. There you need to split, e.g. :
Dim Splitter() As String
Splitter = Split(AddrMail, ";")
For Each Dest In Splitter
.Recipients.Add (Trim(Dest))
Next
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