This is code to send emails from an Excel file.
I want to choose the Outlook account from which the emails are sent ("abc#abc.com").
Sub SendEmail()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = Range("B" & i).Value
.To = Range("A" & i).Value
.Body = Range("C" & i).Value
'.CC = Range("G" & i).Value
'.Send
.display 'disable display and enable send to send automatically
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
I think you're after the SentOnBehalfOfName property:
With Mail_Object.CreateItem(o)
.Subject = Range("B" & i).Value
.To = Range("A" & i).Value
.Body = Range("C" & i).Value
.SentOnBehalfOfName = "abc#abc.com"
'.CC = Range("G" & i).Value
'.Send
.display 'disable display and enable send to send automatically
End With
Related
I have a small piece of vba-code running perfect in office 2010. When running in office 365, it gives an "index out of range"-error, but not when I step into the code with the Outmail-variabele open in the locals-window. The aim of the code is to attach one or more pdf's to a template mail.
The error is when Display in yellow.
Sub Mailing()
Dim OutApp As Object
Dim OutMail As Object
Dim onderworpenNL As String
Dim onderworpenFR As String
onderworpenNL = "some text"
onderworpenFR = "some text"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItemFromTemplate("\\res.sys.shared....\macromail_mail1.oft")
With OutMail
.SentOnBehalfOfName = "dd#dd.com"
.to = Range("H" & (ActiveCell.Row))
.Subject = "some text: " & Range("B" & (ActiveCell.Row)) & " - " & "account: " & Range("A" & (ActiveCell.Row))
.HTMLBody = Replace(.HTMLBody, "REPLACENAAM", Range("B" & (ActiveCell.Row)))
.HTMLBody = Replace(.HTMLBody, "REPLACEWHK", Range("C" & (ActiveCell.Row)))
.HTMLBody = Replace(.HTMLBody, "REPLACEREDENNL", Range("F" & (ActiveCell.Row)))
.HTMLBody = Replace(.HTMLBody, "REPLACEREDENFR", Range("F" & (ActiveCell.Row)))
If Range("G" & (ActiveCell.Row)).Value = "Yes" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENNL", onderworpenNL)
If Range("G" & (ActiveCell.Row)).Value = "No" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENNL", "")
If Range("G" & (ActiveCell.Row)).Value = "Yes" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENFR", onderworpenFR)
If Range("G" & (ActiveCell.Row)).Value = "No" Then .HTMLBody = Replace(.HTMLBody, "REPLACEONDERWORPENFR", "")
On Error Resume Next
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & ".pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_1.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_2.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_3.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_4.pdf"
.Attachments.Add "\\res.sys.shared....\retour\" & Range("A" & (ActiveCell.Row)) & "_5.pdf"
On Error GoTo 0
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Just change
Set OutMail = OutApp.CreateItemFromTemplate("\\res.sys.shared....\macromail_mail1.oft")
For
Set OutMail = OutApp.CreateItem(0)
and it shall work in both excels
This VBA code for Excel should take info from specific cells in each row to populate an automated email follow up.
The code moves through each row of the sheet and opens an email draft in Outlook. This is problematic when the sheet has too many lines, Outlook will typically crash.
I tried using various loops but it either breaks the script or causes the draft to reopen forcing me to have to kill Outlook.
Is there a way to have open the draft and wait until the window is either closed or sent before it moves on to the next line?
I am using .Display rather than .Send so that the email drafts can be reviewed, edited, or cancelled prior to send.
Is there something that checks for .Display = True before moving to the new row in Excel?
Sub SendEmails()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim Name As String
Dim FirstName As String
Dim LastName As String
Dim Temp
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("W").Cells.SpecialCells(xlCellTypeConstants)
i = cell.Row
Temp = Split(Sheets("Sheet1").Range("P" & i).Value)
FirstName = WorksheetFunction.Proper(Temp(LBound(Temp)))
If Sheets("Sheet1").Range("A" & i).Value = "Yellow" And Sheets("Sheet1").Range("AE" & i).Value = "Red" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.subject = "Yellow Red" & Sheets("Sheet1").Range("A" & i).Value & " - " & Sheets("Sheet1").Range("D" & i).Value
.HTMLBody = "<p>Good Afternoon " & FirstName & "," & "</p>" & "<p>Thank you for Yellow.</p>" & "<p> Thanks </p>"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
If Sheets("Sheet1").Range("A" & i).Value = "Blue" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.subject = "Blue" & Sheets("Sheet1").Range("A" & i).Value & " - " & Sheets("Sheet1").Range("D" & i).Value
.HTMLBody = "<p>Good Afternoon " & FirstName & "," & "</p>" & "<p>Thank you for Blue.</p>" & "<p> Thanks </p>"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
If Sheets("Sheet1").Range("A" & i).Value = "Yellow" And Sheets("Sheet1").Range("AE" & i).Value <> "Red" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.subject = "Yellow" & Sheets("Sheet1").Range("A" & i).Value & " - " & Sheets("Sheet1").Range("D" & i).Value
.HTMLBody = "<p>Good Afternoon " & FirstName & "," & "</p>" & "<p>Thank you for Yellow .</p>" & "<p> Thanks </p>"
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
not tested
first of all , sorry for replying with answer, i cannot comment due to not enough rep.
Ok i did some research online on your question, you might want to look into .Display True
It seems adding "True" to the display it makes the pop-up window modal.
being modal puts the loop on hold until you click the send the email.
just wanted to let you know about this , but cant comment.
I am creating VBA code to send email when submit button is clicked. I have 2 conditions, example: in column A it will filter data that contains "AD" and will be sent to recipient A. and in column G if it contains "13" or "14" it will be filtered and sent to recipient B. I already got the 1st condition but I don't know how to add the second condition. else is not working.
Sub BSPProfitCenter_Rectangle3_Click()
Const cFirst As Integer = 20
Const cLast As Integer = 65
Const cRequest As String = "New Request"
Dim i As Integer
For i = cFirst To cLast
If Range("A" & i).Value = cRequest Then
If Range("e" & i).Value = "" Then
MsgBox "Provide the PC name from KE53"
Exit Sub
ElseIf Range("g" & i).Value = "" Then
MsgBox "Please provide the user responsible (Sector) maintained in KE53 for this PC"
Exit Sub
ElseIf Range("K" & i).Value = "" Then
MsgBox "Provide the company code where the PC needs to be extended"
Exit Sub
End If
End If
Next i
ActiveSheet.Unprotect Password:="PROFITCENTER"
Selection.AutoFilter
ActiveSheet.Range("$B$19:$L$65").AutoFilter Field:=1, Criteria1:="=AD*", Operator:=xlAnd
ActiveSheet.SaveAs Filename:="C:\Apps\" & "GSAP Asset Domain PC Request" & Format(Now(), "DD-MM-YYYY")
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 = "A"
.CC = ""
.BCC = ""
.Subject = "AD Request"
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Exit Sub
'here's the supposed to be additional validation'
If Range("s" & i).Value <> "AD" Then
If Range("G" & i).Value = "13" Or Range("G" & i).Value = "14" Then
ActiveSheet.Unprotect Password:="PROFITCENTER"
Selection.AutoFilter
ActiveSheet.Range("$B$19:$L$65").AutoFilter Field:=6, Criteria1:="=13", _
Operator:=xlOr, Criteria2:="=14"
ActiveSheet.SaveAs Filename:="C:\Apps\" & "GSAP PC Request" & Format(Now(), "DD-MM-YYYY")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = "B"
.CC = ""
.BCC = ""
.Subject = "13 & 14 Request"
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
End If
End Sub
I wanted to have 2 conditions in one submit button but the second code is not working.
First of all, you say:
in column A it will filter data that contains "AD"
while in code you write:
If Range("s" & i).Value <> "AD"
which indicated column S, not A - pay attention to that.
You got your Ifs wrong, because it look somewhat like this:
If Range("s" & i).Value <> "AD" Then
If Range("G" & i).Value = "13" Or Range("G" & i).Value = "14" Then
' do all logic here
End If
End If
Which also can be rewritten as:
If Range("s" & i).Value <> "AD" And (Range("G" & i).Value = "13" Or Range("G" & i).Value = "14") Then
' do all logic here
End If
You don't have any separation between those conditions, which you want to treat separately.
It should be written as:
If Range("s" & i).Value <> "AD" Then
' send mail to recipient A
End If
If Range("G" & i).Value = "13" Or Range("G" & i).Value = "14" Then
' send mail to recipient B
End If
I am using below code to send email from excel when user press the button. it works fine. i actually want to fine tune this because right now what is happening is when in Column C there is a duplicate email and in column N it is all yes separate emails are generated. what i want to do is if there is a duplicate email in column C one email should be generated with subject and body from the duplicate rows
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
'On Error Resume Next
LastRow = Range("C" & Rows.Count).End(xlUp).Row
For Each Cell In Range("C8:C" & LastRow)
If WorksheetFunction.CountIf(Range("C8:C" & Cell.Row), Cell) = 1 Then
If Cells(Cell.Row, 14) = "Yes" Then
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Dear " & Cells(Cell.Row, 2) & vbNewLine & vbNewLine & _
Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & vbNewLine & _
"were issue to you for project " & Cells(Cell.Row, 8) & vbNewLine & vbNewLine & vbNewLine & vbNewLine & _
"This is a system generated email and doesn't require signature"
On Error Resume Next
With xOutMail
.To = Cells(Cell.Row, 3)
.CC = Cells(Cell.Row, 5)
.BCC = ""
.Subject = Cells(Cell.Row, 7) & " " & Cells(Cell.Row, 6) & " Issued to " & Cells(Cell.Row, 4)
.Body = xMailBody
'.Attachments.Add ActiveWorkbook.FullName
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End If
End If
Next Cell
You can try:
Option Explicit
Public Sub Get_Unique_Count_Paste_Array()
Dim Ob As Object
Dim rng As Range
Dim LR As Long
Dim str As String
With Worksheets("Sheet1")
LR = .Range("C" & Rows.Count).End(xlUp).Row
Set Ob = CreateObject("scripting.dictionary")
For Each rng In .Range("C8:C" & LR)
str = Trim(rng.Value)
If Len(str) > 0 Then
Ob(str) = Ob(str) + 1
If Ob(str) = 1 Then '<= Check how many times email address appears in the array & if it s appears only one time then..
MsgBox str '<= Insert your code here
End If
End If
Next rng
End With
End Sub
Hi I have all my clients email address in row A on my excel sheet Named "Email". I have created the code below so that a box pops up when I press a bottom on the sheet and I can type the subject, and a few body lines. I want to be able to send the same message to all my client. IE for promotion or if we had to shut the office unexpectedly ect. Can any one help please?
Private Sub CommandButtonSend_Click()
Dim Email_Subject, Email_Send_From, Email_Body1, Email_Body2, Email_Sig, Email_Twitter As String
Dim Mail_Object, Mail_Single As Variant
Dim emailrange As Range, cell As Range
Dim Email_Send_To As String
Set emailrange = Worksheets("Email").Range("A2:A4")
For Each cell In emailrange
Email_Send_To = Email_Send_To & "j" & cell.Value
Next
Email_Send_To = Mid(Email_Send_To, 2)
On Error Resume Next
Email_Subject = UserFormTemplate.TextBoxSubject.Text
Email_Send_From = "shaunha#coversure.co.uk"
Email_Body1 = UserFormTemplate.TextBoxLine1.Text
Email_Body2 = UserFormTemplate.TextBoxLine2.Text
Email_Sig = UserFormTemplate.TextBoxSig.Text
Email_Twitter = UserFormTemplate.TextBoxTwitter.Text
On Error GoTo debugs
Set Mail_Object = CreateObject("Outlook.Application")
Set Mail_Single = Mail_Object.CreateItem(0)
With Mail_Single
.Subject = Email_Subject
.To = Email_Send_To
.cc = Email_Cc
.BCC = Email_Bcc
.Body = Email_Body1 & vbNewLine & Email_Body2 & vbNewLine & vbNewLine & "Shaun Harrison Insurance Consultant" & vbNewLine & "Tel: 0800 308 1022 / shaunha#coversure.co.uk" & vbNewLine & vbNewLine & Email_Twitter
.send
End With
debugs:
If Err.Description <> "" Then MsgBox Err.Description
End
End Sub
Sub SendySend()
With ActiveSheet
EndRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
RowCount = 4
For XCount = 4 To EndRow
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.application")
Dim olmail As Outlook.MailItem
Set olmail = olApp.CreateItem(olMailItem)
If Range("D" & RowCount).Value = "Yes" Then
olmail.To = Range("A" & RowCount).Value
olmail.Subject = Range("B" & RowCount).Value
olmail.Body = Range("C" & RowCount).Value
olmail.Send
Else
DontSend = 1 'This Doesn't do anything at all, it's just for clarity
End If
RowCount = RowCount + 1
Next
End Sub