Send individual PDF's with contact list in Excel - Specify "From" in a cell

[FigueCitron]

HI,

I tried to send some PDF with contact list in Excel. I found a code on internet and try to change it a little bit. I'm new with VBA and I'm learning by myself
I would like to change the Email of the person sending the Email.
I'd like The Email address is based on a specific cell. To put a specific Email address so It'll be accessible for users with no understanding at all with VBA.

I tried to add : outlookmailitem.From = Dir(Range("K9").Value) in the code but it doesn't work...
Everything is working Is a I delete this line but I'm the sender and I don't want that.

Can you help me please.
Thanks a lot

Sub Send_email_fromexcel()
Dim Email_Address_1 As String
Dim Subject As String
Dim Email_Address_2 As String
Dim CC As String
Dim message As String
Dim filename As String
Dim outlookapp As Object
Dim outlookmailitem As Object
Dim myAttachments As Object
Dim Path As String
Dim lastrow As Integer
Dim Attachment As String
Dim x As Integer


x = 2


Do While Sheet1.Cells(x, 1) <> ""

Set outlookapp = CreateObject("Outlook.Application")
Set outlookmailitem = outlookapp.CreateItem(0)
Set myAttachments = outlookmailitem.Attachments
Path = "PATH"
Email_Address_1 = Sheet1.Cells(x, 1)
Email_Address_2 = Sheet1.Cells(x, 2)
CC = Sheet1.Cells(x, 3)
Subject = Sheet1.Cells(x, 4)
filename = Sheet1.Cells(x, 6)
Attachment = Path + filename



outlookmailitem.From = Dir(Range("K9").Value)
outlookmailitem.To = Email_Address_1
outlookmailitem.CC = Email_Address_2
outlookmailitem.BCC = CC
outlookmailitem.Subject = Subject
outlookmailitem.Body = "TEXT"


myAttachments.Add (Attachment)
outlookmailitem.Display
outlookmailitem.send

lastrow = lastrow + 1
Email_Address_1 = ""
x = x + 1


Loop




Set outlookapp = Nothing
Set outlookmailitem = Nothing




MsgBox "All the documents have been sent"


End Sub

[gmayor]

You cannot simply change the sender address. You can either change the sending account, which will change the sender to that account or you can send on behalf of someone. I have no idea what your text in bold is supposed to do.

https://www.gmayor.com/email_merge_addin.html (https://www.gmayor.com/email_merge_addin.html) will facilitate merging from Excel to e-mail and allow you to add PDF attachments identified in the data source.

[FigueCitron]

You'll find below the VBA code without the bold :


Sub Send_email_fromexcel()
Dim Email_Address_1 As String
Dim Subject As String
Dim Email_Address_2 As String
Dim CC As String
Dim message As String
Dim filename As String
Dim outlookapp As Object
Dim outlookmailitem As Object
Dim myAttachments As Object
Dim Path As String
Dim lastrow As Integer
Dim Attachment As String
Dim x As Integer




x = 2


Do While Sheet1.Cells(x, 1) <> ""

Set outlookapp = CreateObject("Outlook.Application")
Set outlookmailitem = outlookapp.CreateItem(0)
Set myAttachments = outlookmailitem.Attachments
Path = "PATH"
Email_Address_1 = Sheet1.Cells(x, 1)
Email_Address_2 = Sheet1.Cells(x, 2)
CC = Sheet1.Cells(x, 3)
Subject = Sheet1.Cells(x, 4)
filename = Sheet1.Cells(x, 6)
Attachment = Path + filename



outlookmailitem.To = Email_Address_1
outlookmailitem.CC = Email_Address_2
outlookmailitem.BCC = CC
outlookmailitem.Subject = Subject
outlookmailitem.Body = "Please find your account Statement" & vbCrLf & vbCrLf & "Best Regards "


myAttachments.Add (Attachment)
outlookmailitem.Display
outlookmailitem.send

lastrow = lastrow + 1
Email_Address_1 = ""
x = x + 1


Loop




Set outlookapp = Nothing
Set outlookmailitem = Nothing




MsgBox "All the documents have been sent"


End Sub

How can I change the sending account?

Thanks for your help

[gmayor]

You need something like


Sub Send_email_fromexcel()
Dim Email_Address_1 As String
Dim Subject As String
Dim Email_Address_2 As String
Dim CC As String
Dim message As String
Dim filename As String
Dim outlookapp As Object
Dim oAccount As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim outlookmailitem As Object
Dim Path As String
Dim lastrow As Integer
Dim Attachment As String
Dim x As Integer
Dim bAcc As Boolean
Const sAcc As String = "someone@somewhere.com" 'Displayname of account to use

x = 2

'it would be better to use the code from 'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to start Outlook
Set outlookapp = CreateObject("Outlook.Application") 'before the loop!

'Check the available accounts for the required account.
For Each oAccount In outlookapp.Session.Accounts
If oAccount.DisplayName = sAcc Then
bAcc = True
Exit For
End If
Next
'Set action if account is not found
If Not bAcc = True Then
MsgBox "The account " & sAcc & " was not found." & vbCr & "Messages will be sent using the default account"
End If

Do While Sheet1.Cells(x, 1) <> ""
Path = "PATH" 'Where does this come from? - Don't forget the path separator!
Email_Address_1 = Sheet1.Cells(x, 1)
Email_Address_2 = Sheet1.Cells(x, 2)
CC = Sheet1.Cells(x, 3)
Subject = Sheet1.Cells(x, 4)
filename = Sheet1.Cells(x, 6)
Attachment = Path & filename

Set outlookmailitem = outlookapp.CreateItem(0)
With outlookmailitem
If bAcc = True Then .SendUsingAccount = oAccount
.To = Email_Address_1
.CC = Email_Address_2
.BCC = CC
.Subject = Subject
.BodyFormat = 2 'html
.Attachments.Add Attachment

Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.Collapse 1

oRng.Text = "Please find your account Statement" & vbCrLf & vbCrLf & "Best Regards "
.Display
.Send
End With

lastrow = lastrow + 1
Email_Address_1 = ""
x = x + 1
Loop

Set outlookapp = Nothing
Set outlookmailitem = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Set oAccount = Nothing

MsgBox "All the documents have been sent"
End Sub