VBA send out email using pickable email account.

gd6noob

Board Regular
Joined
Oct 20, 2017
Messages
102
Office Version
  1. 2016
Platform
  1. Windows
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.

VBA Code:
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
ABCD
1
2ToNameBodyAttachment
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
ABC
1
2Select Email Account
3
4
Dashboard
Cells with Data Validation
CellAllowCriteria
B3ListPersonal, Work



If this is possible, please provide some help.
 

Some videos you may like

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

gd6noob

Board Regular
Joined
Oct 20, 2017
Messages
102
Office Version
  1. 2016
Platform
  1. Windows
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?

VBA Code:
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
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,127,107
Messages
5,622,780
Members
415,927
Latest member
vedasinternational

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top