Attribute VB_Name = "basGetSenderAddy"
' *******************************************************************
' basGetSenderAddy
' Author:       Sue Mosher, Slipstick Systems, sue@slipstick.com
' Date:         8 Sep 2000
' Ver:          1.0
' Desc:         Demonstrates how to get the From and Reply To addresses
'               from an Outlook message
'               Unrestricted public use allowed of this code is allowed

' References:   Microsoft Outlook 9.0 Object Library
'               Microsoft CDO 1.21 Library
' *******************************************************************

Option Explicit
Const CdoE_ACCESSDENIED = 80070005


' *******************************************************************
' Name: ShowAddresses
' Desc: For currently displayed or selected message, prints both the
'       From and Reply To addresses to the Immediate window
' In:   Nothing
' Out:  Nothing
' *******************************************************************
Sub ShowAddresses()
    Dim obj As Object
    
    Set obj = GetCurrentItem()
    If obj.Class = olMail Then
        Debug.Print GetFromAddress(obj)
        Debug.Print GetReplyToAddress(obj)
    End If
    
    Set obj = Nothing
End Sub


' *******************************************************************
' Name: GetFromAddress
' Desc: Returns the address of the sender of the message
' In:   MailItem object
' Out:  From address unless an error is encountered. If there is an
'       error, it returns "".
' *******************************************************************
Function GetFromAddress(objMsg As Outlook.MailItem)
    Dim objSession As MAPI.Session
    Dim objCDOMsg As MAPI.Message
    Dim strEntryID As String
    Dim strStoreID As String
    Dim strAddress As String
    
    ' start CDO session
    Set objSession = CreateObject("MAPI.Session")
    objSession.Logon , , False, False
    
    ' pass message to CDO
    strEntryID = objMsg.EntryID
    strStoreID = objMsg.Parent.StoreID
    Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)
    
    ' get sender address
    On Error Resume Next
    strAddress = objCDOMsg.Sender.Address
    If Err = CdoE_ACCESSDENIED Then
        'handle possible security patch error
        MsgBox "The Outlook E-mail and CDO Security Patches are " & _
               "apparently installed on this machine. " & _
               "You must response Yes to the prompt about " & _
               "accessing e-mail addresses if you want to " & _
               "get the From address.", vbExclamation, _
                "GetFromAddress"
    End If
    
    GetFromAddress = strAddress
    
    On Error GoTo 0
    Set objCDOMsg = Nothing
    objSession.Logoff
    Set objSession = Nothing
End Function


' *******************************************************************
' Name: GetReplyToAddress
' Desc: Returns the reply address of the sender of the message
' In:   MailItem object
' Out:  Reply To address unless an error is encountered. If there is an
'       error, it returns "".
' *******************************************************************
Function GetReplyToAddress(objMsg As Outlook.MailItem)
    Dim objReply As Outlook.MailItem
    Dim objRecip As Outlook.Recipient
    Dim strAddress As String
    
    Set objReply = objMsg.Reply
    On Error Resume Next
    Set objRecip = objReply.Recipients.Item(1)
    If Err = 0 Then
        ' address will be in Name or Address depending
        ' on sending application and type of address
        strAddress = objRecip.Address
        If strAddress = "" Then
            strAddress = objRecip.Name
        End If
    ElseIf Err = 287 Then
        strAddress = ""
        MsgBox "The Outlook E-mail Security Patch is " & _
               "apparently installed on this machine. " & _
               "You must response Yes to the prompt about " & _
               "accessing e-mail addresses if you want to " & _
               "get the Reply To address.", vbExclamation, _
               "GetReplyToAddress"
    End If
    GetReplyToAddress = strAddress

    On Error GoTo 0
    Set objRecip = Nothing
    Set objReply = Nothing
End Function


' *******************************************************************
' Name: GetCurrentItem
' Desc: Returns the Outlook item either currently displayed or, if
'       the active window shows a folder, the first selected item
' In:   Nothing
' Out:  Outlook item
' *******************************************************************
Function GetCurrentItem() As Object
    Dim objApp As Application
    Dim objSel As Outlook.Selection
    Dim objItem As Object
            
    Set objApp = CreateObject("Outlook.Application")
    Select Case objApp.ActiveWindow.Class
        Case olExplorer
            Set objSel = objApp.ActiveExplorer.Selection
            If objSel.Count > 0 Then
                Set objItem = objSel.Item(1)
            End If
        Case olInspector
            Set objItem = objApp.ActiveInspector.CurrentItem
        Case Else
            ' can't handle any other kind of window
    End Select
    
    Set GetCurrentItem = objItem
    
    Set objItem = Nothing
    Set objSel = Nothing
    Set objApp = Nothing
End Function