VBA send out email using pickable email account.

[gd6noob]

I have found a code and edited to work for me but I would like some addtional funcationality.

At my work, we have our own email alias and a shared inbox alias.

Sub SendMail()

Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range

Set objOutlook = CreateObject("Outlook.Application")
Set ws = Set ws = Worksheet("Email")
Dim signature As String
Dim LstRow As Long
LstRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

Dim oAccount As Outlook.Account

For Each oAccount In Outlook.Application.Session.Accounts

If oAccount = "work@work.com" Then

For Each cell In ws.Range("A3:A" & LstRow)

Set objMail = objOutlook.CreateItem(0)
signature = objMail.Body
   With objMail
    .To = ws.Cells(cell.Row, 1).Value
    .Subject = "Lockdown Guidance - Operations (Ne répondez pas / Do no reply)"
    .Body = ws.Cells(cell.Row, 3).Value
  
    Set rng = ws.Cells(cell.Row, 1).Range("D1:Z1")
   
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell.Value) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell
  
  
   Set .SendUsingAccount = oAccount
    .send
End With

    Set objMail = Nothing
Next cell
Else
End If

Next
Set ws = Nothing
Set objOutlook = Nothing

End Sub

Email.xlsb
	A	B	C	D
1
2	To	Name	Body	Attachment
3
Sheet1

I was thinking of having a selectable dropdown to pick which email account to send from. I cant really hardcode it in as we have 25 members in my office and I would like this to be used from everyone.

Email.xlsb
	A	B	C
1
2		Select Email Account
3
4
Dashboard

Cells with Data Validation
Cell	Allow	Criteria
B3	List	Personal, Work

If this is possible, please provide some help.

 

[gd6noob]

I edited the code a bit to grab Body from a word doc. It works to send to 1 email but when I have more, it doesnt work. It also doesnt copy images over. Just text, anyway to solve this?

Sub SendMail()

Dim objOutlook As Object, objMail As Object, OutApp As Object, OutMail As Object
Dim ws As Worksheet, sh As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
Dim signature As String
Dim LstRow As Long
Dim oAccount As Outlook.Account
Dim wd As Word.Application
Dim doc As Word.Document

Set objOutlook = CreateObject("Outlook.Application")
Set ws = Sheets("Email")
Set wd = CreateObject("Word.Application")
    wd.Visible = True
Set doc = wd.Documents.Open(Filename:="C:\Users\leonge\Desktop\Email\Updates.docx", ReadOnly:=True)
    'Copy the open document
    doc.Content.Select
    Word.Selection.Copy


LstRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

For Each oAccount In Outlook.Application.Session.Accounts

If oAccount = "leonge@amazon.com" Then

For Each cell In ws.Range("A3:A" & LstRow)

    Set objMail = objOutlook.CreateItem(0)
    signature = objMail.Body
       With objMail
        .To = ws.Cells(cell.Row, 1).Value
        .Subject = ws.Cells(cell.Row, 2).Value
        .Body = Word.Selection
      
        Set rng = ws.Cells(cell.Row, 1).Range("D1:Z1")
       
               For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell.Value) <> "" Then
                       If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                       End If
                   End If
                Next FileCell
      
        doc.Close
        wd.Quit

       Set .SendUsingAccount = oAccount
        .Send
    End With

    Set objMail = Nothing
Next cell
Else
End If

Next
Set ws = Nothing
Set objOutlook = Nothing

End Sub