Send email to send on behalf email address

I've set up an macro to send an email to whatever the "sent on behalf name" is.

Sometimes the name isn't in the contacts list, is there a way I can do this by e-mail address instead?
If the sent on behalf name is not recognised I receive a Visual Basic debug error...

Outlook does not recognize one or more names.
With olkMessage
            .Recipients.Add Item.SentOnBehalfOfName
            .HTMLBody = "<FONT face=Arial color=#004782>Dear " & Item.SentOnBehalfOfName & ", <br><br></FONT>" & .HTMLBody
            .HTMLBody = .HTMLBody & InsertSignature()
        End With

Open in new window

Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

omgangIT ManagerCommented:
You can't get the SentOnBehalfOfAddress from the Outlook object model.  Extended MAPI exposes that so you'll need to use something like Redemption for Outlook to acquire the SentOnBehalfOfAddress value.  See my sample code below.  It captures the sender address AND the SentOnBehalfOfAddress and stores it in a local table.  You should be able to modify for your needs.
OM Gang

Public Sub ImportFromMailFolder()
On Error GoTo Err_ImportFromMailFolder

        'declare and open instance of MS Outlook
    Dim olOutlook As New Outlook.Application
    Dim olNS As Outlook.NameSpace
    Dim olFolders As Outlook.MAPIFolder
    Dim olInbox As Outlook.MAPIFolder
    Dim olSubFolder As Outlook.MAPIFolder
    Dim olItems As Outlook.Items
    Dim olInboxItem As Outlook.MailItem
    Dim SafeItem As Redemption.SafeMailItem  '<-- requires reference to the Redemption Outlook Library
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim strPSTName As String, strFolderName As String
    Dim strCriteria As String, strMsgBody As String
    Dim strAddress As String, strTableName As String, strBehalfAddress As String
    Dim strSubFolderName As String
    Dim intCounter As Integer
        'extended MAPI attribute contstant
    Const PR_SENT_REPRESENTING_EMAIL_ADDRESS = &H65001E   '<--  this is the extened MAPI attribute for SentOnBehalfOfAddress
        'assign Display Name of outlook mailbox or PST file we want to use to string
    strPSTName = "Mailbox - Gang, OM"
        'name of folder in PST file we want to work with
    strFolderName = "Inbox"
        'name of sub folder in PST file we want to work with - if applicable
    strSubFolderName = "SomeSubFolderInInbox"
        'set object Outlook NameSpace
    Set olNS = olOutlook.GetNamespace("MAPI")
        'set object NameSpace Folders for PST file
    Set olFolders = olNS.Folders(strPSTName)
        'set object mail folder for PST file
    Set olInbox = olFolders.Folders(strFolderName)
        'set object mail sub folder for PST file
    Set olSubFolder = olInbox.Folders(strSubFolderName)

        'set object messages in folder
        'you will use one or the other
    'Set olItems = olInbox.Items
        'set object messages in sub folder
    Set olItems = olSubFolder.Items
        'create instance of Redemption Safe MailItem
    Set SafeItem = CreateObject("Redemption.SafeMailItem")

        'assign local table name we want to populate
    strTableName = "SomeLocalTable"
        'create instance of current db
    Set db = CurrentDb
        'open table as recordset
    Set rs = db.OpenRecordset(strTableName, dbOpenDynaset)
        'display hourglass while working
    DoCmd.Hourglass True
        'loop through list of mail messages
    For intCounter = 1 To olItems.Count
        Set olInboxItem = olItems(intCounter)
            'assign Outlook item to Redemption Safe MailItem
        SafeItem.Item = olInboxItem
            'find messages that match the criteria
        'If olInboxItem.To = strCriteria Then
        '        'assign message body to string variable
        '    strMsgBody = olInboxItem.Body
        'End If
            'get sender address
        strAddress = olInboxItem.SenderEmailAddress
            'get sent of behalf of address from Redemption
        strBehalfAddress = SafeItem.Fields(PR_SENT_REPRESENTING_EMAIL_ADDRESS)
        'If strAddress = "" Then
        '    Debug.Print "Empty" & intCounter
        'ElseIf IsNull(strAddress) Then
        '    Debug.Print "Null" & intCounter
        'End If
            'add address to table
            'check to see if this address already exists in the table
            'don't create duplicate
        'If Not IsNull(strAddress) And strAddress <> "" Then
        '    rs.FindFirst ("emlAddress = " & Chr(34) & strAddress & Chr(34))
        '    If rs.NoMatch Then
        '        rs.AddNew
        '        rs!emlAddress = strAddress
        '        rs.Update
        '    End If
        'End If
            'add sent of behalf of address to table
            'check to see if this address already exists in the table
            'don't create duplicates
        If Not IsNull(strBehalfAddress) And strBehalfAddress <> "" Then
            rs.FindFirst ("emlAddress = " & Chr(34) & strBehalfAddress & Chr(34))
            If rs.NoMatch Then
                rs!emlAddress = strBehalfAddress
            End If
        End If
    Next intCounter

        'turn hourglass off
    DoCmd.Hourglass False
        'clear object variables
    Set rs = Nothing
    Set db = Nothing
    Set olInboxItem = Nothing
    Set olItems = Nothing
    Set SafeItem = Nothing
    Set olSubFolder = Nothing
    Set olInbox = Nothing
    Set olFolders = Nothing
    Set olNS = Nothing
    Set olOutlook = Nothing
    Exit Sub
    MsgBox Err.Number & ", " & Err.Description, , "Error"
    Resume Exit_ImportFromMailFolder
End Sub

Open in new window


Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
cbsbutlerAuthor Commented:
Will check these out on Monday when back in the office. thanks!
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.