Below coding is working fine to send an email with the excel range. Just wanted to all "Hello**" at the top of the email Body (Left alignment). Please assist.
Dim OutApp As Object, OutMail As Object
Dim wdDoc As Object, wdRange As Object
Dim rng As Range
Dim i As Long
Set rng = ThisWorkbook.Sheets("Certificate").Range("A1:O36")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.BCC = ""
.Subject = "Subject"
.Display
Set wdDoc = .GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
rng.Copy
wdRange.Paste
DoEvents
Set wdRange = wdDoc.Range(0, wdDoc.Characters.Count)
'wdRange.ParagraphFormat.Alignment = wdAlignParagraphCenter
For i = 1 To wdRange.Tables.Count
wdRange.Tables(i).Rows.Alignment = wdAlignRowCenter
Next i
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try the next way, please:
Sub sendOutlookMail()
Dim OutApp As Object, OutMail As Object
Dim wdDoc As Object, wdRange As Object
Dim rng As Range, i As Long
Set rng = ThisWorkbook.Sheets("Certificate").Range("A1:O36")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = ""
.BCC = ""
.subject = "Subject"
.display
Set wdDoc = .GetInspector.WordEditor
With wdDoc
.Paragraphs(1).Range.InsertAfter ("Hello!" & vbCrLf)
rng.Copy
.Paragraphs(2).Range.Paste
End With
End With
End Sub
Related
I have the following code but it is not working. I am fairly new to VBA as well. The code works to populate the email template but as soon as I add the .Attachment.Add it does not work.
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E2")
Set rngSubject = .Range("E3")
Set rngBody = .Range("E4")
.Attachments.Add "Z:\PHS 340B\Letters of Non-Compliance\..Resources\W9 Form\VPNA W-9 01 09 2017"
End With
With objMail
.to = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
End Sub
Try this:
Sub emailtest()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("E2")
Set rngSubject = .Range("E3")
Set rngBody = .Range("E4")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Body = rngBody.Value
.Attachments.Add "Z:\PHS 340B\Letters of Non-Compliance\..Resources\W9 Form\VPNA W-9 01 09 2017"
.Display 'Instead of .Display, you can use .Send to send the email _
or .Save to save a copy in the drafts folder
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
End Sub
You need to use the .Attachments.Add when working within Outlook not Excel.
This simple script should illustrate the point of how to add attachments to an email, and then send the email.
Sub Mail_workbook_Outlook_1()
'Working in Excel 2000-2016
'This example send the last saved version of the Activeworkbook
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "ron#debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hi there"
.Attachments.Add ActiveWorkbook.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail1.htm
Is there any way I can attach as well as send a worksheet as an email body.
The below VBA code sends the worksheet as an attachment.
How can I send a worksheet in the body of email?
Sub Email()
Dim OutApp As Object
Dim OutMail As Object
Dim wbTemp As Workbook
Dim strFilename As String
Dim Sendrng As Range
ThisWorkbook.Worksheets("Test Worksheet").Copy
Set wbTemp = ActiveWorkbook
wbTemp.SaveAs ThisWorkbook.Path & "/" & "TestWb", XlFileFormat.xlOpenXMLWorkbook
strFilename = wbTemp.FullName
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "test#testdomain.com"
.CC = ""
.BCC = ""
.Subject = "Test Email"
.Body = ""
.Attachments.Add strFilename
.display
End With
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
wbTemp.Close
Kill strFilename
End Sub
Private Sub CommandButton1_Click()
Dim AWorksheet As Worksheet
Dim Sendrng As Range
Dim rng As Range
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sendrng = Worksheets("Sheet1").Range("A1:g15")
Set AWorksheet = ActiveSheet
With Sendrng
.Parent.Select
Set rng = ActiveCell
.Select
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.To = "recipient"
.CC = ""
.BCC = ""
.Subject = "My subject"
.Send
End With
End With
rng.Select
End With
AWorksheet.Select
Sheet1.Activate
Range("c2:c3").ClearContents
Range("e2:e3").ClearContents
Range("c5") = ""
Range("B8:b10").ClearContents
Range("c8:c10").ClearContents
Range("d8:d10").ClearContents
Range("e8:e10").ClearContents
Range("f8:f10").ClearContents
Range("g8:g10").ClearContents
Range("b13") = ""
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
End Sub
you should add your code that also copies it to this. Forgive all the crap you dont need here, I just copy and pasted one I have been using
I am using the already known Subroutine to send a warning email to outlook whenever a condition is met.
In the routine I define an string array under the name DatePassed in which I store some dynamical values and I intent to return it's content in the Subject of the email.
The problem is that I don't know how exactly to handle DatePassed so to return me the whole array not just the first element.
How would I do this?
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Dim DatePassed(100) As Variant
Dim i As Integer
For i = 6 To 13
If Cells(i, 1) < Date Then
DatePassed(i - 6) = Cells(i, 2)
End If
Next i
With OutMail
.To = "Joerge#Johnson.com"
.CC = "James#Johnson.com"
.BCC = ""
.Subject = "Unmanaged Clients"
.Body = DataPassed
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try this.
I have just added a Loop to run through the Array and stored it as a string which then gets assigned to the .Body
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Dim DatePassed(100) As Variant
Dim i As Integer
For i = 6 To 13
If Cells(i, 1) < Date Then
DatePassed(i - 6) = Cells(i, 2)
End If
Next i
'=================================================
'New Section
Dim DataPassedElementReference As Long
Dim DataPassedString As String
DataPassedString = ""
'Using 100 as this is waht you used to define the array
For DataPassedElementReference = 1 To 100
DataPassedString = DataPassedString & DataPassed(DataPassedElementReference) & " "
Next DataPassedElementReference
'=================================================
With OutMail
.To = "Joerge#Johnson.com"
.CC = "James#Johnson.com"
.BCC = ""
.Subject = "Unmanaged Clients"
'Note the difference here
'.Body = DataPassed
.Body = DataPassedString
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I need to send selection range from excell by email and add signature from htm file. I have next code to send selection and it works well:
Sub Send_Selection()
'Working in Excel 2002-2013
Dim Sendrng As Range
Dim strbody As Range
On Error GoTo StopMacro
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Note: if the selection is one cell it will send the whole worksheet
Set Sendrng = Selection
'Create the mail and send it
With Sendrng
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
' Set the optional introduction field thats adds
' some header text to the email body.
.Introduction = ""
With .Item
.To = "dg#siz66.ru"
.CC = ""
.BCC = ""
.Subject = "My subject"
.send
End With
End With
End With
StopMacro:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
End Sub
Next I have code to generate mail with signature from html file:
Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
SigString = "C:\Users\d.gazdovsky\Downloads\sign.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = strbody & "<br>" & Signature
.display 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Now I need only to combine this macros to solve my problem. Please help me with it. Thanks in advance
UPD 1: I try thi code, but it give error..
Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2013
Dim OutApp As Object
Dim OutMail As Object
Dim Sendrng As Range
Dim strbody As Range
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Note: if the selection is one cell it will send the whole worksheet
Set Sendrng = Selection & Signature
'Create the mail and send it
With Sendrng
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
' Set the optional introduction field thats adds
' some header text to the email body.
.Introduction = ""
With .Item
.To = "dg#siz66.ru"
.CC = ""
.BCC = ""
.Subject = "My subject"
.send
End With
End With
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
SigString = "C:\Users\d.gazdovsky\Downloads\sign.htm"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
'.HTMLBody = Sendrng & "<br>" & Signature
.display 'or use .Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
I have code to send email. I'm struggling to CC the sender? If I mail I should get the CC, if my colleague mails he should get the CC.
Our usernames aren't firstname.lastname but our email addresses are.
Sub SendPDF()
Dim strPath As String, strFName As String
Dim OutApp As Object, OutMail As Object
Title = Format(Now(), "dd/mm/yyyy") & " - " & ActiveSheet.Name & ""
strPath = Environ$("temp") & "\" 'Or any other path, but include trailing "\"
strFName = ActiveWorkbook.Name
strFName = Format(Now(), "yyyymmdd") & " - " & ActiveSheet.Name & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
strPath & strFName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "firstname.surname#email.com"
.CC = ""
.BCC = ""
.Subject = Title
.body = "Please see attached"
.Attachments.Add strPath & strFName
'.Display
.Send
End With
Kill strPath & strFName
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You can use the CurrentUser property of the Namespace class to get the currently logged-on user as a Recipient object. Then you can get the Address property value which representing the e-mail address of the Recipient.
.CC = nameSpace.CurrentUser.Address;
Also you may find the How To: Fill TO,CC and BCC fields in Outlook programmatically article helpful.
Sub email()
Dim a As Integer
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngCc As Range
Dim rngBcc As Range
Dim rngSubject As Range
Dim rngAttach As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("B1")
Set rngCc = .Range("B2")
Set rngBcc = .Range("B3")
Set rngSubject = .Range("B4")
Set rngAttach = .Range("B5")
Set rngBody = .Range("B6")
End With
With objMail
.To = rngTo.Value
.Cc = rngCc.Value
.Bcc = rngBcc.Value
.Subject = rngSubject.Value
.Attachments.Add rngAttach.Value
.Body = rngBody.Value
.Display
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngCc = Nothing
Set rngBcc = Nothing
Set rngSubject = Nothing
Set rngAttach = Nothing
Set rngBody = Nothing
End Sub
I know this is kind of old, but I ended up here, so someone else might!
I was able to get the sender CC'd using the namespace (at least in an exchange environment). In my case, the CurrentUser. The address returned a string like the following:
/o=ExchangeLabs/ou=Exchange Administrative Group (XXXXXXXXXXXXXXXX)/cn=Recipients/cn=XXXXXXXXXXXXXXXXXXXXXXXXXXXXX-XXXXXXX
This was resolved successfully, and successfully CC'd the sender.
Might also look at Get sender's email address with Excel VBA
Sub TestCC()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim OutNS As Outlook.Namespace
' Get open Outlook, or create a new instance
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
' Get MAPI Namespace
Set OutNS = OutApp.GetNamespace("MAPI")
' Create Mail Item
Set OutMail = OutApp.CreateItem(olMailItem) 'Item type 0
' Build email
On Error Resume Next
With OutMail
.To = "first.last#email.com"
.CC = OutNS.CurrentUser.Address
.BCC = ""
.Subject = "Email Subject Line"
.Body = "Body Text"
' Resolve added recipients
.Recipients.ResolveAll
' Display or Send created email
.Display
'.Send
End With
' Clean up
Set OutMail = Nothing
Set OutNS = Nothing
Set OutApp = Nothing
End Sub