Select account to send email from

Frankietheflyer

New Member
Joined
Nov 17, 2017
Messages
30
Hi

I have a code that runs through a list of people and sends individual files to each one. The code automatically sends the emails from one of two email accounts I have. Problem is, it's the account that isn't associated with the message!

As this spreadsheet will be used by many different people I can't "hard wire" it to the correct account s
o I need to be able to select which account is used to send the email out under.

I think there are probably two ways of doing this:

1.If there is more than one account when I start to run the code it asks me to type in the account address I want to send the emails from and uses that one.

2. The code automatically finds all the accounts I have in outlook (one's a "live.com.au" and the other is "y7mail.com") and lets me select the one I want to use.

It also needs to recognise if someone only has one email account and just carry on.

Anyone got a code that can do either of these?

My current code for sending the emails is as follows
Code:
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Private Sub MailSheets_Click()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim File As Variant
    Dim myFile As Variant, FolderName As String
    Dim strPath As String, rngWB As Range, wsRO As Worksheet
    
[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]    Set sh = Sheets("Contacts")[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]    Set OutApp = CreateObject("Outlook.Application")[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]     For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]        'Enter the path/file names in the C:C column in each row
        
        Set rng = sh.Cells(cell.Row, 1).Range("C1:C100")
        
File = ("C:\Users\" & Environ("USERNAME") & ("\Documents\PDF Completed Sheets for Team Captains ") & ThisWorkbook.Sheets("Running Order").Range("F1").Value & ("\") & cell.Offset(0, 1) & ".pdf")[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]
        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]            With OutMail
                .to = cell.Value
                .Subject = cell.Offset(0, 4) & " Team Sheet"
                .Body = "Hi " & cell.Offset(0, 2).Value & Chr(13) & Chr(13) & "Please find the Competed Team Sheet for " & cell.Offset(0, 4) & " attached." _
                        & Chr$(13) & Chr$(13) & "Trust you had fun!"[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]                   .Attachments.Add File
                            
                 '.Display    'Or use
                 .Send
            End With[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]            Set OutMail = Nothing
        End If
    Next cell[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]MsgBox "Emails have been sent"
End Sub[/FONT]
[FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif][/FONT]

Thanks everyone!

Frankie
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Just to do a test.
Add the following line:

Code:
With OutMail
  [COLOR=#0000ff].SendUsingAccount = OutMail.Session.Accounts.Item(2)[/COLOR]

Item(1) = "live.com.au"
Item(2) = "
y7mail.com"
 
Upvote 0
Hi DanteAmor

Thanks for the response. First, the code tells me that the Variable is not defined. I put [FONT=Verdana,Arial,Tahoma,Calibri,Geneva,sans-serif]Dim Item(1) As Range, Item(2) As Range, but it then told me I had a duplicate declaration under current scope, so I took the () out from around the numbers in the DIMs and in the Code. The code then stops at the .SendUsingAccount line with the warning that the Object doesn't support this property or method.

I also wondered if I'd need to put the whole address in against the Item= rather than just the live.com.au end bit.

Like the idea but it's not quite there yet!

Frankie
[/FONT]
 
Upvote 0
Sorry for not explaining well.
Perform a test with the following to send mail by account "y7mail.com"

Code:
Private Sub MailSheets_Click()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim File As Variant
    Dim myFile As Variant, FolderName As String
    Dim strPath As String, rngWB As Range, wsRO As Worksheet
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set sh = Sheets("Contacts")
    Set OutApp = CreateObject("Outlook.Application")
     For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        'Enter the path/file names in the C:C column in each row
        
        Set rng = sh.Cells(cell.Row, 1).Range("C1:C100")
        
File = ("C:\Users\" & Environ("USERNAME") & ("\Documents\PDF Completed Sheets for Team Captains ") & ThisWorkbook.Sheets("Running Order").Range("F1").Value & ("\") & cell.Offset(0, 1) & ".pdf")


        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                [COLOR=#0000ff].SendUsingAccount = OutMail.Session.Accounts.Item([/COLOR][COLOR=#ff0000][B]2[/B][/COLOR][COLOR=#0000ff])[/COLOR]
                .to = cell.Value
                .Subject = cell.Offset(0, 4) & " Team Sheet"
                .Body = "Hi " & cell.Offset(0, 2).Value & Chr(13) & Chr(13) & "Please find the Competed Team Sheet for " & cell.Offset(0, 4) & " attached." _
                        & Chr$(13) & Chr$(13) & "Trust you had fun!"
                   .Attachments.Add File
                            
                 '.Display    'Or use
                 .Send
            End With
            Set OutMail = Nothing
        End If
    Next cell
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
MsgBox "Emails have been sent"
End Sub


Perform a test with the following to send mail by account "live.com.au"
Code:
Private Sub MailSheets_Click()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim File As Variant
    Dim myFile As Variant, FolderName As String
    Dim strPath As String, rngWB As Range, wsRO As Worksheet
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set sh = Sheets("Contacts")
    Set OutApp = CreateObject("Outlook.Application")
     For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        'Enter the path/file names in the C:C column in each row
        
        Set rng = sh.Cells(cell.Row, 1).Range("C1:C100")
        
File = ("C:\Users\" & Environ("USERNAME") & ("\Documents\PDF Completed Sheets for Team Captains ") & ThisWorkbook.Sheets("Running Order").Range("F1").Value & ("\") & cell.Offset(0, 1) & ".pdf")


        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            With OutMail
                [COLOR=#0000ff].SendUsingAccount = OutMail.Session.Accounts.Item([/COLOR][COLOR=#ff0000]1[/COLOR][COLOR=#0000ff])[/COLOR]
                .to = cell.Value
                .Subject = cell.Offset(0, 4) & " Team Sheet"
                .Body = "Hi " & cell.Offset(0, 2).Value & Chr(13) & Chr(13) & "Please find the Competed Team Sheet for " & cell.Offset(0, 4) & " attached." _
                        & Chr$(13) & Chr$(13) & "Trust you had fun!"
                   .Attachments.Add File
                            
                 '.Display    'Or use
                 .Send
            End With
            Set OutMail = Nothing
        End If
    Next cell
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
MsgBox "Emails have been sent"
End Sub

Note: As you can see, you just have to add a line and change the number.
 
Upvote 0
Hi DanteAmor

Sorry for the delay in getting back to you but I was busy over the weekend. For some reason changing the number makes no difference. The emails still come out of the live.co.au address. I wondered if it's anything to do with Yahoo not being part of Outlook. However, I'll do a bit more fiddling and see what I can come up with.

Thanks for the advice so far

Frankie
 
Upvote 0
Do you have configured the 2 accounts in outlook?

Your accounts look like the following image:

22537892921b356a5f00e048dbe1edbf.jpg
 
Upvote 0
Rub this in the Outlook ThisOutlookSession module
Code:
Sub Which_Account_Number()    Dim OutApp As Outlook.Application
    Dim I As Long
    Set OutApp = CreateObject("Outlook.Application")
    For I = 1 To OutApp.Session.Accounts.Count
        MsgBox OutApp.Session.Accounts.Item(I) & " : This is account number " & I
    Next
End Sub
 
Upvote 0
Thanks for the suggestion Paul Ked. With a bit (lot?!) of help I've actually got a code that finds the address of my email accounts and allows me to select one, then puts that address into cell L1 on the worksheet. The next issue is how do I get the code sending the email to use the address in L1 to send it from?

In place of "Set OutMail = OutApp.CreateItem(0)" I've tried "Set OutMail = sh.Range("L1")" and identifying sh.Range ("L1") as .Item(1) then using "Set OutMail = OutApp.Session.Accounts.Item(1)" but neither seems to work.

The latest code is as follows:

Code:
Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    Dim File As Variant
    Dim myFile As Variant, FolderName As String
    Dim strPath As String, rngWB As Range, wsRO As Worksheet
    
    Dim SendFrom As Range
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set sh = Sheets("Contacts")
    Set OutApp = CreateObject("Outlook.Application")
     For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
              
        Set rng = sh.Cells(cell.Row, 1).Range("C1:C100")
        
File = ("C:\Users\" & Environ("USERNAME") & ("\Documents\PDF Completed Sheets for Team Captains ") & ThisWorkbook.Sheets("Running Order").Range("F1").Value & ("\") & cell.Offset(0, 1) & ".pdf")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            
                                                                                                                     'Set OutMail = OutApp.CreateItem(0)
            
            Set OutMail = sh.Range("L1")                                                             'OutApp.Session.Accounts.Item(1)
            
            With OutMail
            
                .To = cell.Value
                .Subject = cell.Offset(0, 4) & " Team Sheet"
                .Body = "Hi " & cell.Offset(0, 2).Value & Chr(13) & Chr(13) & "Please find the Competed Team Sheet for " & cell.Offset(0, 4) & " attached." _
                        & Chr$(13) & Chr$(13) & "Trust you had fun!"
                   .Attachments.Add File
                            
                 '.Display    'Or use
                 .Send
            End With
            Set OutMail = Nothing
        End If
    Next cell
    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
MsgBox "Emails have been sent"
End Sub

<strike>
</strike>
 
Upvote 0
As Dante said, once you know the Outlook account number
Code:
            With OutMail
[COLOR=#0000CD]                .SendUsingAccount = OutMail.Session.Accounts.Item([/COLOR][COLOR=#ff0000]1[/COLOR][COLOR=#0000CD])[/COLOR]
                .to = cell.Value
                .Subject = cell.Offset(0, 4) & " Team Sheet"
                .Body = "Hi " & cell.Offset(0, 2).Value & Chr(13) & Chr(13) & "Please find the Competed Team Sheet for " & cell.Offset(0, 4) & " attached." _
                        & Chr$(13) & Chr$(13) & "Trust you had fun!"
                   .Attachments.Add File
                            
                 '.Display    'Or use
                 .Send
            End With

Add the blue line with the account number in red.
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,504
Messages
6,114,016
Members
448,543
Latest member
MartinLarkin

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
Back
Top