vba - Switching the FROM Inbox

Question

I currently use a code that generates an email fine with certain fields like To, CC, BCC, but I am not sure how to switch the "FROM" part of the email automatically.

Ie my email is here, but I want to automatically switch to another inbox,

I can do it manually when the email is generated via the drop down, but I am wondering if there are ways to do this automatically. I Tried adding .From to this existing code but does not work.

Here are the relevant snippets of code:

Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Set Mitem = OLook.CreateItem(0)

With Mitem
            
                'send to:
                .To = send_list
            
                'send from:
                '.From = from_list
            
            
                'cc to:
                .CC = cc_list
                
                'bcc to:
                .BCC = bcc_list

.From = from_list is not a supported property.

Does anyone know how to alter this code to add the "From" parameter correctly?

FULL CODE

Sub Create_Email()

' Creates e-mail to send

    Application.ScreenUpdating = False
    Sheets("Emails Management").Select
    ActiveSheet.Calculate
    
    top_line_emails = 2 'hardcoded to row 2
    max_row_emails = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row - 1  'last row
    ref_title_line = Application.WorksheetFunction.Match("Email Name", Columns(1), False)      'gets title row
    
     
    indexActive = Application.WorksheetFunction.Match("Active", Rows(ref_title_line), False)
    indexType = Application.WorksheetFunction.Match("Type", Rows(ref_title_line), False)
    indexEmailName = Application.WorksheetFunction.Match("Email Name", Rows(ref_title_line), False)
    indexsubject = Application.WorksheetFunction.Match("Subject", Rows(ref_title_line), False)
    indexfiles = Application.WorksheetFunction.Match("Attachments", Rows(ref_title_line), False)
    indexSendTo = Application.WorksheetFunction.Match("Send To", Rows(ref_title_line), False)
    indexSendFrom = Application.WorksheetFunction.Match("Send From", Rows(ref_title_line), False)
    indexCC = Application.WorksheetFunction.Match("CCed", Rows(ref_title_line), False)
    indexBCC = Application.WorksheetFunction.Match("BCCed", Rows(ref_title_line), False)
    indexGreetings = Application.WorksheetFunction.Match("Greetings", Rows(ref_title_line), False)
    indexBody = Application.WorksheetFunction.Match("Body Text", Rows(ref_title_line), False)
    indexSignature = Application.WorksheetFunction.Match("Signature", Rows(ref_title_line), False)
    
    
    Dim OLook As Object, Mitem As Object, OlAttachment As Object
    Dim fso As Object
    Dim remail As Range
    Dim acc As Object
    Dim oMail As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    user_name = Environ("Username")
    
    ref_row = top_line_emails 'hardcoded for row 2
    
    'finds the reports that were generated
    Do While ref_row <= max_row_emails
    
        Set OLook = CreateObject("Outlook.Application")
        Set Mitem = OLook.CreateItem(0)
        Set OlAttachment = Mitem.attachments
        
        send_list = ""
        from_list = ""
        cc_list = ""
        bcc_list = ""
        attach_name = ""
        whole_text = ""
        Body_text = ""
        
        If Range(ColumnNumberToLetter(indexEmailName) & ref_row).Value = "" Then   'looping down the rows, if it is blank stop generating emails.
            Exit Do
        End If
        
        go_for_it = True
        
           
        If go_for_it = True Then

        
            file_name = Range(ColumnNumberToLetter(indexfiles) & ref_row).Value
            send_list = Range(ColumnNumberToLetter(indexSendTo) & ref_row)
            from_list = Range(ColumnNumberToLetter(indexSendFrom) & ref_row)
            cc_list = Range(ColumnNumberToLetter(indexCC) & ref_row)
            bcc_list = Range(ColumnNumberToLetter(indexBCC) & ref_row)
            Signature = Range(ColumnNumberToLetter(indexSignature) & ref_row).Value
            attachment = Range(ColumnNumberToLetter(indexfiles) & ref_row).Value 'not attaching
                                                                                            
            'On Error GoTo no_email, Gets the text of the Email
            Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexGreetings) & ref_row)
                                  
                                  
            'This section gets the text part of the email.
            If remail = "" Then
                greetings_text = ""
            Else
                greetings_text = RangetoHTML2(remail)
                greetings_text = get_date_cnv(greetings_text, ref_date_email)
            End If
            
            'Body text , Meant for charts
            If Range(ColumnNumberToLetter(indexBody) & ref_row).Value <> "" Then
                body_full_text = Range(ColumnNumberToLetter(indexBody) & ref_row).Value
                
                'count the number of < in the body text
                graphic_count = Len(body_full_text) - Len(Replace(body_full_text, "<", ""))
                
                For Count = 1 To graphic_count
                    'search the start and end of the graphic range
                    body_start_search = InStr(1, body_full_text, "<")
                    body_end_search = InStr(1, body_full_text, ">")
                    
                    'if there are <> then go for it
                    If body_start_search <> 0 And body_end_search <> 0 Then
                    
                        'isolate the text in the <>
                        graphic_area = RTrim(LTrim(Mid(Left(body_full_text, body_end_search), body_start_search)))
                        
                        'make sure the <> is not a <br> (line break)
                        If graphic_area <> "" And graphic_area <> "<br>" Then
                            
                            'body_text = body_text & Left(body_full_text, body_start_search - 1)
                            
                            graphic_area = Replace(Replace(graphic_area, "<", ""), ">", "")
                            
                            'pull out the graphic type
                            graphic_type_search = InStr(1, graphic_area, ",")
                            graphic_type = Left(graphic_area, graphic_type_search - 1)
                            graphic_area = RTrim(LTrim(Right(graphic_area, Len(graphic_area) - graphic_type_search)))
                            
                            'pull out the tab name
                            graphic_tab_search = InStr(1, graphic_area, ",")
                            graphic_tab = Left(graphic_area, graphic_tab_search - 1)
                            
                            'pull out the graphic area
                            graphic_rng = RTrim(LTrim(Right(graphic_area, Len(graphic_area) - graphic_tab_search)))
                            
                            Select Case LCase(graphic_type)
                                
                                Case "chart"
                                    Body_text = Body_text & "<br>" & RangetoHTML(Sheets(graphic_tab).Range(graphic_rng))
                                
                                Case "text"
                                    Body_text = Body_text & "<br>" & RangetoHTML2(Sheets(graphic_tab).Range(graphic_rng))
                                
                                'Need to put graph part here
                                
                            End Select
                            
                            If Len(body_full_text) = body_end_search Then
                                Exit For
                            End If
                            
                            body_full_text = Right(body_full_text, Len(body_full_text) - body_end_search - 1)
                        Else
                            If IsEmpty(Body_text) Then
                                Body_text = Left(body_full_text, body_start_search - 1)
                            Else
                                
                                If Len(body_full_text) = body_end_search Then
                                    Exit For
                                End If
                                
                                Body_text = Body_text & "<br>" & Left(body_full_text, body_start_search - 1)
                            End If
                            
                            If Len(body_full_text) = body_end_search Then
                                Exit For
                            End If
                            
                            body_full_text = Right(body_full_text, Len(body_full_text) - body_end_search - 1)
                        End If
     
                        Else
                            Body_text = Body_text & body_full_text & "<br>"
                    End If
                        
                Next Count
                
                Body_text = Body_text & "<br>" & body_full_text
            End If
            
            Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexBody) & ref_row)

            'signature
            Set remail = Sheets("Emails Management").Range(ColumnNumberToLetter(indexSignature) & ref_row)
            end_text = RangetoHTML2(remail)
            
            'creates the whole text in email
            whole_text = greetings_text & "<br>" & Body_text & "<br>" & "<br>" & end_text
            
            'create email, but does not send
          Set Mitem = OLook.CreateItem(0)
            With Mitem
      
                .SendUsingAccount = GetAccountOf("email@blah.com", OLook)
                .Display
            
                'send to:
                .To = send_list
            
            
                'cc to:
                .CC = cc_list
                
                'bcc to:
                .BCC = bcc_list
                
              
                'attaching files
                           
                On Error GoTo resume_here
                
                If Range(ColumnNumberToLetter(indexfiles) & ref_row).Value <> "" Then
                   file_name = Sheets("Emails Management").Range(ColumnNumberToLetter(indexfiles) & ref_row).Value
                                     
                   file_count = Len(file_name) - Len(Replace(file_name, ";", "")) 

Answer 1

Try this function

Function GetAccountOf(sEmailAddress As String, ByRef OLook As Object) As Object
  Dim oAccount As Object
  Set GetAccountOf = Nothing
  For Each oAccount In OLook.Session.Accounts
    If oAccount = sEmailAddress Then
      Set GetAccountOf = oAccount
      Exit Function
    End If
  Next oAccount
End Function

You can then replace the .From line with:

  .SendUsingAccount = GetAccountOf("emailaddress@somewhere.com", OLook)

Edit: Follow-up to comments below:

If the above doesn't work then I suspect there's something with your outlook that is causing this. You need to think of ways/questions to help determine the problem, such as

• Is the account you want to use completely set-up within outlook?
• When you send email manually from this account does outlook ask you for password?

Try also to think of test code you can use to narrow down the possibilities that may be the cause of the problem. for example try to run these subroutines and see if the first code actually lists your desired account. Does the second code result in the account being Nothing? If so, perhaps an option is to delete the account and add it again to outlook, which may help reset something that was causing the problem.

Sub ShowAllAccounts()
  Dim OLook As Object
  Dim oAccount As Object
  Set OLook = CreateObject("Outlook.Application")
  For Each oAccount In OLook.Session.Accounts
    MsgBox oAccount.DisplayName
  Next oAccount
End Sub

Sub DoesAccountExist()
  Dim OLook As Object
  Set OLook = CreateObject("Outlook.Application")
  If GetAccountOf("emailaddress@somewhere.com", OLook) Is Nothing Then
    MsgBox "Account doesn't exist"
  End If
End Sub

Try to make up some other code similar to this and please get back if you are still stuck.

Edit 2:

You need to make sure you set the SendUsingAccount property before you .Display your email: Outlook if funny like that :)

Try this:

Dim OLook As Object, Mitem As Object, OlAttachment As Object
Dim fso As Object
Dim remail As Range
Dim acc As Object
Set Mitem = OLook.CreateItem(0)

With Mitem
                .SendUsingAccount = GetAccountOf("emailaddress@somewhere.com", OLook)       
                .Display

                'send to:
                .To = send_list
            
                'send from:
                '.From = from_list
            
            
                'cc to:
                .CC = cc_list
                
                'bcc to:
                .BCC = bcc_list