Outlook VBA Set From field for another mailbox

If you have working settings for both accounts then the reply from can likely be set within outlook ... When sending mails do you have a drop down to allow selection of the sender?

Chris

Hi Chris,

Thanks for the reply.

Basically the shared mailbox recieves an e-mail which is detected by my code. This e-mail needs to be forwarded on to a a particular mail group depending on the e-mail. The e-mail though needs to have the From field as "Blah@work.com" rather than "Mark@work.com". All of this needs to be automated so not sure if the drop down will be of use?

I also need the e-mails I send normally during the day to have the From field as "Mark@work.com".

Hope that makes sense

Thanks

If the drop down is there then it means the account (blah) is set up.  Assuming it is set up then we can access it through VBA.  CDO is one possibility of course but so is the outlook interface, and if it is setup then we can minimise the risk of making the account details visible as well as keep the sent item in the sent items folder.

Chris

Ok sounds good. Going to sound stupid where do i find the drop down option? Our IT team take away lot of the functionality of our programs.

Mark

Do you mean the drop down list in the From Field? If so then yes I can see that address in the list.

Cheers

Okay then lets return to the functionality as I think it's viable ...

When you receive emails from a number of senders you have some code already that is triggered ... what you want in these cases is to automatically forward these items to someone else using the blah setup rather than the default mark one?

Assuming so then how is your code executed and is the recipient always the same?

Chris

Yes thats excatly it. The recipient is not always the same the code quickly detects which recipient at run time. The code is executed in the following way below. All of the code is in "ThisOutlookSession"

Declared at the top,

Dim WithEvents olCorp As Outlook.Items

Select allOpen in new window

Private Sub Application_MAPILogonComplete()

On Error GoTo Err_Application_Startup
    
    Set olCorp = OpenOutlookFolder("Mailbox - FI Corporate Actions\Inbox").Items
    
Exit_Application_Startup:
    Exit Sub

Err_Application_Startup:
    MsgBox Err.Number & ", " & Err.Description, , "Error in Sub Application_Startup of VBA Document ThisOutlookSession"
    Resume Exit_Application_Startup
   
End Sub

Private Sub Application_Quit()
On Error GoTo Err_Application_Quit

    Set olCorp = Nothing

Exit_Application_Quit:
    Exit Sub

Err_Application_Quit:
    MsgBox Err.Number & " (" & Err.Description & ") in procedure Application_Quit of VBA Document ThisOutlookSession"
    Resume Exit_Application_Quit

End Sub

Private Sub olCorp_ItemAdd(ByVal Item As Object)

Dim Email As Outlook.MailItem

    On Error GoTo errHandler:
    
    Set Email = Item
    FindDistributionList(Email)              ' this finds out the required distribution list then forwards the e-mail on
     
errHandler:
    Exit Sub

End Sub

Select allOpen in new window

forgot to put this bit of code in as well,

Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        olCorp As Outlook.MAPIFolder
    On Error GoTo ehOpenOutlookFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        If Left(strFolderPath, 1) = "\" Then
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        End If
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olCorp) Then
                Set olCorp = Session.Folders(varFolder)
            Else
                Set olCorp = olCorp.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olCorp
    End If
    On Error GoTo 0
    Exit Function
ehOpenOutlookFolder:
    Set OpenOutlookFolder = Nothing
    On Error GoTo 0
End Function

Select allOpen in new window

   FindDistributionList(Email)              ' this finds out the required distribution list then forwards the e-mail on

As it says this bit of code forwards the email so presumably this is where the selection occurs as well as the send ... and it is therefore likey here that the change needs to be placed ... can you supply this bit of code?

Chris

The function just returns the e-mail address to use - the code is not fully written. I'm planning to put the send bit in Private Sub olCorp_ItemAdd(ByVal Item As Object) right below the FindDistributionList function. The function is just looking at strings nothing to actually do with Outlook if that makes sense.

Cheers
Mark

How is an email arriving in the olcorp folder.... Is it the new mail to be sent or an email to be responded to?

Chris

A mail is sent to the Corp mailbox. The code then fires an event and works out the e-mail has to be forwarded onto, with the the From field set as "Copr@work.com".

I will post the rest of my spaghetti code in a moment if you need further info.

Cheers
Mark

All my code if you can follow it. Apologies in advanced for the lack of structure.

Cheers

Dim WithEvents olCorp As Outlook.Items

Private Const StateStreetEmail As String = "mark@work.com"
Private Const strSearch As String = "Fund Code:"
Private Const strExt As String = " -***Auto***"
Private Const strDB As String = "G:\Shared\CorpDB.mdb;"

Private Type TypeFundInformation
    Code As String
    Desk As String
    Email As String
End Type

Private Type TypeSearch
    Position As Integer
    Code As String
End Type

Private Sub olCorp_ItemAdd(ByVal Item As Object)

Dim Email As Outlook.MailItem

' errHandler needed

If TypeName(Item) = "MailItem" Then         ' check the item is an actual e-mail not a meeting, contact or report item
    Set Email = Item
    CorpActionsMain Email
End If
    
End Sub

Private Sub CorpActionsMain(Email As Outlook.MailItem)

Dim FundsInfo() As TypeFundInformation
Dim CorpInfo() As TypeFundInformation
Dim Result As TypeFundInformation
Dim SearchInfo As TypeSearch
Dim ctr As Integer

If InStr(1, Email.Subject, strExt) > 0 Then             ' its a reply from Fund Manager needs to be forwarded to STeam    
    ' from field needs to be set
    With Email
        .To StateStreetEmail
        .Forward
        .Send
    End With
    
Else                                                    ' possibly a new corporate action

    FundInfo = QueryDatabase                            ' 1st get list of fund we need to check for & the corresponding e-mail address
                                                        
    ' search email to check which if any desks are affected
    SearchInfo.Position = 1                             ' intialise to stop infinite loop
    
    Do Until SearchInfo.Position = 0
        
        SearchInfo = SearchEmailN(Email.Body, SearchInfo.Position)
            
            If SearchInfo.Position <> 0 Then            ' a code has been found
                
                Result.Desk = GetCodeInfo(SearchInfo.Code, FundsInfo)
                
                If DeskAlreadyInDistList(Result.Desk, CorpInfo) = False Then    ' see if e-mail address already exists. to stop dupilcating emails
                    ctr = ctr + 1
                    ReDim Preserve CorpInfo(1 To ctr)
                    CorpInfo(ctr).Desk = Result.Desk
                    CorpInfo(ctr).Email = Result.Email
                End If
            
            End If
    Loop
    
    If ctr > 0 Then
        For ctr = 1 To UBound(CorpInfo)
            With Email
                .To = CorpInfo.Email
                .Subject = .Subject & strExt            ' strExt used to distingiush between corp action sent from STeam & a reply from the fund managers
                .Forward
                .Send
            End With
        Next
    End If
    
End If

End Sub

Private Function QueryDatabase() As TypeFundInformation()

Dim i As Integer
Dim strSQL As String
Dim FundInfo() As TypeFundInformation
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

    Set cn = New ADODB.Connection
        cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDB
        
    ' if password is needed for Corp database
    'cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strDB & "Persist Security Info=False;Jet OLEDB:Database Password="
        
    strSQL = "SELECT Desk_Funds.[Desk], Desk_Funds.[Fund Code], Distribution_List.[Email Address] " & _
                "FROM Distribution_List " & _
                "INNER JOIN Desk_Funds ON Distribution_List.Desk = Desk_Funds.Desk;"
    
    Set rs = New ADODB.Recordset
    rs.Open strSQL, cn, adOpenKeyset
    
    If rs.EOF = False Then
        rs.MoveFirst
        
        ReDim FundData(1 To rs.RecordCount)
                    
            For i = 1 To UBound(FundList)
                FundInfo(i).Desk = rs![Desk]
                FundInfo(i).Code = rs![Fund Code]
                FundInfo(i).Email = rs![Email Address]
                rs.MoveNext
            Next
    End If
    
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    
    QueryDatabase = FundInfo

End Function

Private Function SearchEmailN(EmailBody As String, Position As Integer) As TypeSearch

Dim Result As TypeSearch
Dim i As Integer
    
    Result.Position = InStr(Position, EmailBody, strSearch)
    
        If Result.Position <> 0 Then
                        
            i = 1
            Do Until Mid(EmailBody, Result.Position + Len(strSearch) + i, 1) = Chr(10) _
                            Or Mid(EmailBody, Position + Len(strSearch) + 1, 1) = Chr(13) _
                                Or i >= 10
                Result.Code = Result.Code & Mid(EmailBody, Position + Len(strSearch) + 1, 1)
                i = i + 1
            Loop

            Result.Position = Result.Position + 1
                
        End If

    SearchEmailN = Result

End Function

Private Function GetCodeInfo(Code As String, _
                                FundInfo() As TypeFundInformation) As TypeFundInformation

Dim Res As TypeFundInformation
Dim i As Integer

For i = 1 To UBound(FundInfo)
    If Code = FundInfo(i).Code Then
        Res.Code = FundInfo(i).Code
        Res.Desk = FundInfo(i).Desk
        Res.Email = FundInfo(i).Email
        GetCodeInfo = Res
        Exit Function
    End If
Next

End Function

Private Function DeskAlreadyInDistList(Desk As String, _
                                            CorpInfo() As TypeFundInformation) As Boolean

Dim i As Integer

For i = 1 To UBound(CorpInfo)
    If CorpInfo(i).Desk = Desk Then
        DeskAlreadyInDistList = True
        Exit Function
    End If
Next

End Function

Select allOpen in new window

The basic mechanism is to sendusingaccount ... the first is the default account but if the selection is wrong then change the value in "Application.Session.Accounts.item(2)".

In the instance item.forward will create a forward but you could equally use:

    With item.Reply

The .display simply displays the email as is ... though other properties can be set as appropriate and the email can be sent automatically bu using .send instead of .display ... but depending on security the send may trigger the warning.

Chris

With item.Forward
        .sendusingaccount = Application.Session.Accounts.item(2)
        .Display
    End With

Select allOpen in new window

I do not that option Application.Session.Accounts? I have Application.Session. Am I missing a reference or is it becuase I am using Outlook 2003?

Cheers

Thats brillant, works perfectly. Thanks for all your help Chris