I have an old script to send multiple mails from excel using Cell values, 1st cell is the E-Mail address, 2nd is Mail Subject, 3rd contains the mail body, it doesn't work anymore!! HELP PLZ
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngEntry As Range
Dim rngEntries As Range
Set objOutlook = CreateObject("Outlook.Application")
Set rngEntries = ActiveSheet.Range("B:B")
For Each rngEntry In rngEntries
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = rngEntry.Value
.Subject = rngEntry.Offset(0, 1).Value
.Body = rngEntry.Offset(0, 2).Value
'.Attachments.Add rngEntry.Offset(0, 3).Value
.Send '.Display or .Save
End With
Next rngEntry
Set objOutlook = Nothing
Set objMail = Nothing
Set rngEntry = Nothing
Set rngEntries = Nothing
End Sub
Your vba code does send emails to any names in column B. However, when it hits the first row with no data it attempts to send an email without a "To:" party. This fix will stop the subroutine when it hits an empty cell in column B:
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngEntry As Range
Dim rngEntries As Range
Set objOutlook = CreateObject("Outlook.Application")
Set rngEntries = ActiveSheet.Range("B:B")
For Each rngEntry In rngEntries
If rngEntry.Value <> "" Then ' ADD THIS LINE HERE
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = rngEntry.Value
.Subject = rngEntry.Offset(0, 1).Value
.Body = rngEntry.Offset(0, 2).Value
'.Attachments.Add rngEntry.Offset(0, 3).Value
.Send '.Display or .Save
End With
Else ' ADD THIS LINE HERE
Exit Sub ' ADD THIS LINE HERE
End If ' ADD THIS LINE HERE
Next rngEntry
Set objOutlook = Nothing
Set objMail = Nothing
Set rngEntry = Nothing
Set rngEntries = Nothing
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
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
I have the existing code to send a mail from a Sheet in my Excel file -
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Application.ScreenUpdating = False
Worksheets("Mail List").Activate
With ActiveSheet
Set rngTo = .Range("B1")
Set rngSubject = .Range("B2")
Set rngBody = .Range("B3")
Set rngAttach = .Range("B4")
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.body = rngBody.Value
.Attachments.Add rngAttach.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
Set rngAttach = Nothing
End Sub
However, I want to include a number of attachments, and hence the
Set rngAttach = .Range("B4") does not help to do this.
Any help on this?
Thanks in advance!
Enclose your .Attachments.Add statement in loop. Something like below might work
For i = 4 To 6
.Attachments.Add Range("B" & i).Value
Next i
To make it Dynamic you can set the upper limit of i to the last row in Column B
For i = 4 To Range("B" & rows.count).end(xlUp).row
.Attachments.Add Range("B" & i).Value
Next i
This updated code:
Looks for file names from B4
Uses Dir to ensure the attached files actually exist at the specified path
Tidies up the worksheet code (Activate is unnecessary)
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim rng2 As Range
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
Application.ScreenUpdating = False
Set ws = Worksheets("Mail List")
With ws
Set rngTo = .Range("B1")
Set rngSubject = .Range("B2")
Set rngBody = .Range("B3")
Set rngAttach = ws.Range(ws.[b4], ws.Cells(Rows.Count, "B").End(xlUp))
End With
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.body = rngBody.Value
For Each rng1 In rngAttach.Cells
If Len(Dir(rng1)) > 0 Then .Attachments.Add rng1.Value
Next
.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
Set rngAttach = Nothing
End Sub
If I click on a button the time should be captured in Column E in the first empty cell starting at cell E5 and if that cell is not empty then it should automatically go to the next cell E6 then E7 ...
Here is the code that I use currently, but it doesn't work:
Sub Button4_Click()
ActiveSheet.Unprotect "pramtesh"
ActiveWorkbook.Unprotect "pramtesh"
ActiveSheet.Value = Time()
ActiveSheet.Protect "pramtesh"
ActiveWorkbook.Protect "pramtesh"
Dim olApp As Object
Dim olMailItm As Object
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
With olMailItm
.To = ""
.CC = ""
.Subject = ""
.Body = ""
.Display
Application.Wait (Now)
Application.SendKeys "%s"
End With
Set olMailItm = Nothing
Set olApp = Nothing
End Sub
There is no need to use the SendKeys method for sending an email programmatically. Instead, I'd suggest using the Send method of the MailItem class. See the Using Automation to Send a Microsoft Outlook Message article for a sample code.
Sub SendMessage(DisplayMsg As Boolean, Optional AttachmentPath)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Nancy Davolio")
objOutlookRecip.Type = olTo
' Add the CC recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Michael Suyama")
objOutlookRecip.Type = olCC
' Add the BCC recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Andrew Fuller")
objOutlookRecip.Type = olBCC
' Set the Subject, Body, and Importance of the message.
.Subject = "This is an Automation test with Microsoft Outlook"
.Body = "This is the body of the message." &vbCrLf & vbCrLf
.Importance = olImportanceHigh 'High importance
' Add attachments to the message.
If Not IsMissing(AttachmentPath) Then
Set objOutlookAttach = .Attachments.Add(AttachmentPath)
End If
' Resolve each Recipient's name.
For Each ObjOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
' Should we display the message before sending?
If DisplayMsg Then
.Display
Else
.Save
.Send
End If
End With
Set objOutlook = Nothing
End Sub
Also you can read more about that in the How to automate Outlook from another program article.
use this
Sub Button4_Click()
Dim iCounter%, Dest As Variant, SDest$, Lrow&
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olMailItm As Object: Set olMailItm = olApp.CreateItem(0)
'determinate the last used cell in column "E"
Lrow = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row
'additional verification
If Lrow < 5 Then 'if last used cell before [E5] then will be used [E5]
Lrow = 5
Else 'otherwise move to the next cell after last filled cell
Lrow = Lrow + 1
End If
ActiveSheet.Unprotect "pramtesh": ActiveWorkbook.Unprotect "pramtesh"
ActiveSheet.Cells(Lrow, "E").Value = Time() 'insert time into the cell
ActiveSheet.Protect "pramtesh": ActiveWorkbook.Protect "pramtesh"
With olMailItm
.To = ""
.CC = ""
.Subject = ""
.Body = ""
.Display
Application.Wait (Now)
Application.SendKeys "%s"
End With
Set olMailItm = Nothing: Set olApp = Nothing
End Sub
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