Outlook VBA Set From field for another mailbox

Hi,

In my work e-mail I have a shared mailbox (with full permission) along with my own private work email inbox. I currently have some code that can detect when an e-mail is recieved in this other mailbox. What I need to do is forward on certain e-mails and have the "From" field as sent from "Blah@work.com" rather than "Mark@work.com".

Can someone please tell me how this is possible? I have read that it might be able to do this by usin the CDO library.

Cheers
mcs26Asked:
Who is Participating?
 
Chris BottomleySoftware Quality Lead EngineerCommented:
The interface was introduced in 2007!

I don't have 2003 in front of me and all my old code is on another machine.  Sue Mosher was always a font of knowledge, (http://www.outlookcode.com/codedetail.aspx?id=889) so try replacing "Personal Folders" with the account name you want to be used.

Chris
With item.Reply
        Set_Account "Personal Folders", item
        .Display
    End With
    
End Sub

Function Set_Account(ByVal AccountName As String, M As Outlook.mailitem) As String
    Dim OLI As Outlook.Inspector
    Dim strAccountBtnName As String
    Dim intLoc As Integer
    Const ID_ACCOUNTS = 31224
  
    Dim CBs As Office.CommandBars
    Dim CBP As Office.CommandBarPopup
    Dim MC As Office.CommandBarControl
  
    Set OLI = M.GetInspector
    If Not OLI Is Nothing Then
        Set CBs = OLI.CommandBars
        Set CBP = CBs.findControl(, ID_ACCOUNTS)
        If Not CBP Is Nothing Then
            For Each MC In CBP.Controls
                intLoc = InStr(MC.caption, " ")
                If intLoc > 0 Then
                    strAccountBtnName = Mid(MC.caption, intLoc + 1)
                Else
                    strAccountBtnName = MC.caption
                End If
                If strAccountBtnName = AccountName Then
                    MC.Execute
                    Set_Account = AccountName
                    GoTo Exit_Function
                End If
            Next
        End If
    End If
    Set_Account = ""
  
Exit_Function:
    Set MC = Nothing
    Set CBP = Nothing
    Set CBs = Nothing
    Set OLI = Nothing
End Function

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
0
 
mcs26Author Commented:
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
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
0
 
mcs26Author Commented:
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
0
 
mcs26Author Commented:
Do you mean the drop down list in the From Field? If so then yes I can see that address in the list.

Cheers
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
0
 
mcs26Author Commented:
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

Open 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

Open in new window


0
 
mcs26Author Commented:
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

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
   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
0
 
mcs26Author Commented:
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

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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
0
 
mcs26Author Commented:
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
0
 
mcs26Author Commented:
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

Open in new window

0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
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

Open in new window

0
 
mcs26Author Commented:
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
0
 
mcs26Author Commented:
Thats brillant, works perfectly. Thanks for all your help Chris
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.