Consulting

Results 1 to 2 of 2

Thread: problems with smtp exchange in the script

  1. #1

    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:
    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

  2. #2
    Script 2:
    ' 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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •