Switching emails VBA..HELP!

Question

So I needed a email code that could send emails from excel, and I have one that works perfectly. But I have several accounts in outlook, and with so many emails it's very time consuming going back and forth having to switch the default email. So I have searched the web for days now and I have found only 2 wesites that have contents that actually look as if they could work.

These are the links that I found:

1. http://www.rondebruin.nl/win/s1/outlook/account.htm

2. http://answers.microsoft.com/en-us/office/forum/office_2010-customize/excel-vba-sending-email-with-outlook-2010-specify/4ae28948-0b01-4eb7-8f5f-10fbfa8f4df9

In those links it talks about how to use VBA from Excel 2007 and up to change the email account that the VBA is sending from. As I am accessible to both outlook and excel 2010 and 2013 (mostly 2013) I thought I could take advantage of having the extra functions to do something like this.

So basically I needed a VBA that can send emails using outlook (I have that). But now I need to add something to it so it can send from different email accounts, as different buttons have different needs.

This is my current VBA:

Sub SendReport()

Dim olApp As Object

Dim olMsg As Object

On Error Resume Next

Set olApp = CreateObject("Outlook.Application")

If olApp Is Nothing Then

MsgBox "Can't start Outlook", vbCritical

Exit Sub

End If

For r = 6 To 1005

If Range("B" & r).Value <> "" Then

s = Range("B" & r).Value

If s <> "" Then

Set olMsg = olApp.CreateItem(0)

olMsg.To = s

olMsg.Subject = "Welcome"

olMsg.Body = "Hello, " & vbCrLf & _

"Thank you for becoming a member " & vbCrLf & vbCrLf & _

"Report Download: " & Range("J17").Value & vbCrLf & _

"Expiration: " & Range("I17").Text & vbCrLf & vbCrLf & _

"Thank you"

olMsg.Display

End If

End If

Next r

Range("I17:J17").ClearContents

MsgBox "Emails have all been sent", vbInformation, "Company Sales"

End Sub

I have tried these methods to try and change the accounts through VBA:

strSender = "******@company.com"

For Each olAccount In olApp.GetNameSpace("IMAP").Accounts

If LCase(olAccount.SmtpAddress) = LCase(strSender) Then

olMsg.SendUsingAccount = olAccount

Exit For

End If

Next olAccount

and

the      .sendonbehalf       method, yet NONE of these work.

So I was wondering if there is a way that you guys could help me take the knowledge from those 2 websites and integrate it into my VBA so that the VBA can change the accounts on outlook when sending emails through excels VBA, (didn't mean to sound aggressive there). I have tried myself but I couldn't accomplish it successfully, especially that I didn't know what I was doing and was just trying to guess where everything went (while putting the code in the most logical locations).

If this could be added it would help me a TON. I didn't even know really how important and how much I needed this feature till I started to use my database.

I would really appreciate all the help possible,

Thank you in advance to everyone who helps me!!

Answer 1

I just re-read Ron's site (http://www.rondebruin.nl/win/s1/outlook/account.htm).

Have you tried doing:

    olMsg.SentOnBehalfOfName = """SenderName"" <replyATaddress.com>"     '<<replace with @

    olMsg.Send

?

Cheers

Rich

Answer 2

Ok so this is the exact code I am using:

Sub ListOutlookAccounts()

Dim olApp As Object

Dim bWeStartedOutlook As Boolean

Dim lnOLAcc As Long

On Error Resume Next

Set olApp = GetObject(, "Outlook.Application")

If olApp Is Nothing Then

Set olApp = CreateObject("Outlook.Application")

If olApp Is Nothing Then

MsgBox "Can't start Outlook", vbCritical

Exit Sub

Else

bWeStartedOutlook = True

End If

End If

On Error GoTo 0

For lnOLAcc = 1 To olApp.Session.Accounts.Count

Debug.Print olApp.Session.Accounts.Item(lnOLAcc) & " : This is account number " & lnOLAcc

Next lnOLAcc

If bWeStartedOutlook Then olApp.Quit

Set olApp = Nothing

End Sub

Sub TestSend()

Call SendReportUsingOLAccount("Company Noreply") 'the only way it would work was by account name not email

End Sub

Sub SendReportUsingOLAccount(strOLAcc As String)

Dim olApp As Object

Dim olMsg As Object

Dim bWeStartedOutlook As Boolean

Dim r As Long, lnOLAcc As Long

Dim s As String

On Error Resume Next

Set olApp = GetObject(, "Outlook.Application")

If olApp Is Nothing Then

Set olApp = CreateObject("Outlook.Application")

If olApp Is Nothing Then

MsgBox "Can't start Outlook", vbCritical

Exit Sub

Else

bWeStartedOutlook = True

End If

End If

On Error GoTo ExitPoint

'Get account number for parsed account name:

For lnOLAcc = 4 To olApp.Session.Accounts.Count 'I change the 1 to 4 as that was the account number

If LCase(olApp.Session.Accounts.Item(lnOLAcc)) = LCase(strOLAcc) Then Exit For

Next lnOLAcc

If lnOLAcc > olApp.Session.Accounts.Count Then

MsgBox "Account " & strOLAcc & " not found!", vbCritical

GoTo ExitPoint

End If

For r = 6 To 1005

s = Range("B" & r).Value

If s <> "" Then

Set olMsg = olApp.CreateItem(0)

olMsg.To = s

olMsg.Subject = "Welcome"

olMsg.Body = "Hello, " & vbCrLf _

& "Thank you for becoming a member " & vbCrLf & vbCrLf _

& "Report Download: " & Range("J17").Value & vbCrLf _

& "Expiration: " & Range("I17").Text & vbCrLf & vbCrLf _

& "Thank you"

olMsg.Display

'olMsg.SendUsingAccount = olApp.Session.Accounts.Item(lnOLAcc)

'olMsg.Send

End If

Next r

Range("I17:J17").ClearContents

MsgBox "Emails have all been sent", vbInformation, "Company Sales"

ExitPoint:

On Error Resume Next

If bWeStartedOutlook Then olApp.Quit

Set olMsg = Nothing

Set olApp = Nothing

End Sub

here is the email list the first macro provides:

XXX : This is account number 1

XXX: This is account number 2

XXX: This is account number 3

XXX: This is account number 1

XXX: This is account number 2

XXX: This is account number 3

XXX: This is account number 4

XXX: This is account number 4

XXX: This is account number 1

XXX: This is account number 2

XXX: This is account number 3

XXX: This is account number 4

XXX: This is account number 1

XXX: This is account number 2

XXX: This is account number 3

XXX: This is account number 4

XXX: This is account number 1

XXX: This is account number 2

XXX: This is account number 3

XXX: This is account number 4

XXX: This is account number 1

XXX: This is account number 2

XXX: This is account number 3

XXX: This is account number 4

XXX = An accounts name (EX: Company Noreply)

As you can see it doesn't give me any emails, it just gives me the account name and a number, and it repeats itself alot of times.

In the sendtest macro, if I didn't put account name instead of the email as you said to, it just gives me the email was not found error.

Even though I changed the account number it uses, it still goes to the default.

What do you recommend doing?

Answer 3

Hi.

First thing to note: did you copy the code from this site?  I did have to make a couple of modifications very soon after I posted it.  If you picked up the code from an e-mail you might have missed these updates.  Please try copying the code from the website again.

With the VBA editor ("VBE") open, run the ListOutlookAccounts macro.  Look in the Immediate window (press Ctrl+G if you can't see it).  You should see a list of all the accounts.  (text is written to the Immediate window using  Debug.Print...   :

    For lnOLAcc = 1 To olApp.Session.Accounts.Count

        Debug.Print olApp.Session.Accounts.Item(lnOLAcc) & " : This is account number " & lnOLAcc

    Next lnOLAcc

You may have that list already... but either way you now have them ready to copy and paste into the following...

Once you know the name of an account, you can edit the argument in calling the SendReportUsingOLAccount procedure:

Sub TestSend()

    Call SendReportUsingOLAccount("my.accountATname.com") '<EDIT THIS

End Sub

Note that this site always removes any e-mail address, hence my use of "AT" instead of @.

So please have another go and let me know what happens.

Cheers

Rich

Answer 4

Hello Rich, I really appreciate your help. But I'm actually confused... So I ran the "ListOutlookAccounts" first as you said and nothing happened. So then I ran the "TestSend" and I got an error which said the account wasn't found, EVEN THE DEFAULT EMAIL.

How can I properly use/fix this VBA?

I would greatly appreciate your further support,

Thank you

Answer 5

Hi,

Try the code below:

First, run this, which will give you a list of all available account names:

Sub ListOutlookAccounts()

    Dim olApp As Object

    Dim bWeStartedOutlook As Boolean

    Dim lnOLAcc As Long

    On Error Resume Next

    Set olApp = GetObject(, "Outlook.Application")

    If olApp Is Nothing Then

        Set olApp = CreateObject("Outlook.Application")

        If olApp Is Nothing Then

            MsgBox "Can't start Outlook", vbCritical

            Exit Sub

        Else

            bWeStartedOutlook = True

        End If

    End If

    On Error GoTo 0

    For lnOLAcc = 1 To olApp.Session.Accounts.Count

        Debug.Print olApp.Session.Accounts.Item(lnOLAcc) & " : This is account number " & lnOLAcc

    Next lnOLAcc

    If bWeStartedOutlook Then olApp.Quit

    Set olApp = Nothing

End Sub

Then you can modify the string "my.accountATname.com" to a valid account name (in my case it was my e-mail address), to call  the SendReportUsingOLAccount procedure.

Sub TestSend()

    Call SendReportUsingOLAccount("my.accountATname.com") '<EDIT THIS

End Sub

Sub SendReportUsingOLAccount(strOLAcc As String)

    Dim olApp As Object

    Dim olMsg As Object

    Dim bWeStartedOutlook As Boolean

    Dim r As Long, lnOLAcc As Long

    Dim s As String

    On Error Resume Next

    Set olApp = GetObject(, "Outlook.Application")

    If olApp Is Nothing Then

        Set olApp = CreateObject("Outlook.Application")

        If olApp Is Nothing Then

            MsgBox "Can't start Outlook", vbCritical

            Exit Sub

        Else

            bWeStartedOutlook = True

        End If

    End If

    On Error GoTo 0 '<<could change to: On Error GoTo ExitPoint   

   'Get account number for parsed account name:    For lnOLAcc = 1 To olApp.Session.Accounts.Count

        If LCase(olApp.Session.Accounts.Item(lnOLAcc)) = LCase(strOLAcc) Then Exit For

    Next lnOLAcc

    If lnOLAcc > olApp.Session.Accounts.Count Then

        MsgBox "Account " & strOLAcc & " not found!", vbCritical

        GoTo ExitPoint

    End If

    For r = 6 To 1005

        s = Range("B" & r).Value

        If s <> "" Then

            Set olMsg = olApp.CreateItem(0)

            olMsg.To = s

            olMsg.Subject = "Welcome"

            olMsg.Body = "Hello, " & vbCrLf _

                & "Thank you for becoming a member " & vbCrLf & vbCrLf _

                & "Report Download: " & Range("J17").Value & vbCrLf _

                & "Expiration: " & Range("I17").Text & vbCrLf & vbCrLf _

                & "Thank you"

            'olMsg.Display            olMsg.SendUsingAccount = olApp.Session.Accounts.Item(lnOLAcc)

olMsg.Send        End If

    Next r

    Range("I17:J17").ClearContents

    MsgBox "Emails have all been sent", vbInformation, "Company Sales"

ExitPoint:

    If bWeStartedOutlook Then olApp.Quit

    Set olMsg = Nothing

    Set olApp = Nothing

End Sub

Note the last hightlighted line there WILL SEND THE MESSAGE (but also note that I haven't tested it since I don't have multiple accounts!).

Cheers

Rich

PS. Notice how I changed the code for making the olApp object.  It will now make use of an existing instance of Outlook, and will only Quit outlook at the end if it was started by the code.