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

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 = [COLOR=var(--black-750)]Dir[/COLOR][COLOR=var(--black-750)]([/COLOR][COLOR=var(--black-750)]Range[/COLOR][COLOR=var(--black-750)]([/COLOR][COLOR=var(--red-800)]"K9"[/COLOR][COLOR=var(--black-750)]).[/COLOR][COLOR=var(--black-750)]Value[/COLOR][COLOR=var(--black-750)]) 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.

[/COLOR]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 = [COLOR=var(--black-750)]Dir[/COLOR][COLOR=var(--black-750)]([/COLOR][COLOR=var(--black-750)]Range[/COLOR][COLOR=var(--black-750)]([/COLOR][COLOR=var(--red-800)]"K9"[/COLOR][COLOR=var(--black-750)]).[/COLOR][COLOR=var(--black-750)]Value[/COLOR][COLOR=var(--black-750)])[/COLOR]
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

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 will facilitate merging from Excel to e-mail and allow you to add PDF attachments identified in the data source.

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

You need something like

Code:

---

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

---