Select account to send email from

[Frankietheflyer]

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

[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

 

[DanteAmor]

Just to do a test.
Add the following line:

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

Item(1) = "live.com.au"
Item(2) = "y7mail.com"

 

[Frankietheflyer]

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]

 

[DanteAmor]

Sorry for not explaining well.
Perform a test with the following to send mail by account "y7mail.com"

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"

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.

 

[Frankietheflyer]

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

 

[DanteAmor]

Do you have configured the 2 accounts in outlook?

Your accounts look like the following image:

 

[Frankietheflyer]

Not like the screen shot. My two accounts show and I can select which one I send an email from when I'm in Outlook.

 

[Paul Ked]

Rub this in the Outlook ThisOutlookSession module

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

 

[Frankietheflyer]

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:

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>}}

 

[Paul Ked]

As Dante said, once you know the Outlook account number

            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.