problems with smtp exchange in the script

Hi!
script number 1 gets the name of the sender. Checks whether a folder with the same name is created or not. Then he moves the letter to the folder with the name of the sender or creates a folder if it is missing. Problems with mail exchage. A folder is created with the name / O = domain / OU = EXCHANGE.
script 2 at startup shows the correct exchange mail. Please help me add the required code from the script 2 so that 1 script correctly displays the smtp name of the sender. Thanks for the help!


script 1:

Code:

---

Private WithEvents Items As Outlook.Items


Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace


  ' set object reference to default Inbox
  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
End Sub


Private Sub Items_ItemAdd(ByVal item As Object)
' fires when new item added to default Inbox
' (per Application_Startup)


  On Error GoTo ErrorHandler


  Dim Msg As Outlook.MailItem
  Dim olApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim targetFolder As Outlook.MAPIFolder
  Dim SenderEmailAddress As String


  ' don't do anything for non-Mailitems
  If TypeName(item) <> "MailItem" Then GoTo ProgramExit


  Set Msg = item


  ' move received email to target folder based on sender name
  SenderEmailAddress = Msg.SenderEmailAddress


  If CheckForFolder(SenderEmailAddress) = False Then  ' Folder doesn't exist
    Set targetFolder = CreateSubFolder(SenderEmailAddress)
  Else
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    Set targetFolder = _
    objNS.GetDefaultFolder(olFolderInbox).Folders(SenderEmailAddress)
  End If


  Msg.Move targetFolder


ProgramExit:
  Exit Sub
ErrorHandler:
  MsgBox Err.Number & " - " & Err.Description
  Resume ProgramExit
End Sub


Function CheckForFolder(strFolder As String) As Boolean
' looks for subfolder of specified folder, returns TRUE if folder exists.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder


Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)


' try to set an object reference to specified folder
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0


If Not FolderToCheck Is Nothing Then
  CheckForFolder = True
End If


ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function


Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder
' assumes folder doesn't exist, so only call if calling sub knows that
' the folder doesn't exist; returns a folder object to calling sub
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder


Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)


Set CreateSubFolder = olInbox.Folders.Add(strFolder)


ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

---

Script 2:

Code:

---

' Outlook VBA Script that gets SMTP Address of the Currently Selected Email
' This script can convert an Exchange address into an SMTP address
' Use Tools->Macro->Security to allow Macros to run, then restart Outlook
' Run Outlook, Press Alt+F11 to open VBA
' Programming by Greg Thatcher,
Option Explicit


Public Sub GetSmtpAddressOfCurrentEmail()
    Dim Session As Outlook.NameSpace
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim currentItem As Object
    Dim currentMail As MailItem
    Dim smtpAddress As String
   
    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection
   
    'for all items do...
    For Each currentItem In Selection
        If currentItem.Class = olMail Then
            Set currentMail = currentItem
            smtpAddress = GetSmtpAddress(currentMail)
            MsgBox "SMTP Address is " & smtpAddress
        End If
    Next
   
End Sub
Public Function GetSmtpAddress(mail As MailItem)
    On Error GoTo On_Error
   
    GetSmtpAddress = ""
   
    Dim Report As String
    Dim Session As Outlook.NameSpace
    Set Session = Application.Session
   
    If mail.SenderEmailType <> "EX" Then
        GetSmtpAddress = mail.SenderEmailAddress
    Else
        Dim senderEntryID As String
        Dim sender As AddressEntry
        Dim PR_SENT_REPRESENTING_ENTRYID As String
       
        PR_SENT_REPRESENTING_ENTRYID = "h_t_tp://schemas.microsoft.com/mapi/proptag/0x00410102"
       
        senderEntryID = mail.PropertyAccessor.BinaryToString( _
            mail.PropertyAccessor.GetProperty( _
                PR_SENT_REPRESENTING_ENTRYID))
       
        Set sender = Session.GetAddressEntryFromID(senderEntryID)
        If sender Is Nothing Then
            Exit Function
        End If
       
        If sender.AddressEntryUserType = olExchangeUserAddressEntry Or _
            sender.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
               
            Dim exchangeUser As exchangeUser
            Set exchangeUser = sender.GetExchangeUser()
           
            If exchangeUser Is Nothing Then
                Exit Function
            End If
           
            GetSmtpAddress = exchangeUser.PrimarySmtpAddress
            Exit Function
        Else
            Dim PR_SMTP_ADDRESS
            PR_SMTP_ADDRESS = "h_t_tp://schemas.microsoft.com/mapi/proptag/0x39FE001E"
            GetSmtpAddress = sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End If
           
       
    End If
   
   
Exiting:
        Exit Function
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting
   
End Function

---