Write to log on itemsend and BCC email to another mailbox

[dsbsaul]

Hello everyone i'm really new here in this forum and i hope i can share knowledge

I'm having problems with a script that write to a file when a user SEND an email, because sometimes it recognizes sender email and sometimes not. This is the code.

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

Dim objRecip As Recipient
Dim strMsg As String
Dim strBcc As String
Dim sHostName As String
Dim sUserName As String
Dim filename As String
Dim wn As Integer
Dim FSO As FileSystemObject
Set FSO = New FileSystemObject
Dim ts As TextStream
On Error GoTo GetOut


wn = Format(Date, "ww")
cyear = Format(Date, "yyyy")
sHostName = Environ$("computername")
sUserName = Environ$("username")
filename = wn & "-" & cyear & "-" & sHostName & ".txt"


SavePath = "routetofile" & filename




SenderName = Item.SentOnBehalfOfName
senderit = Item.sender

'Modified strBcc value i'm new and the post don't allow me to post addresses
strBcc = "emailaddrtoBCC"
Set objRecip = Item.Recipients.Add(strBcc)
    objRecip.Type = olBCC
       If Not objRecip.Resolve Then
        If FSO.FileExists(SavePath) = False Then
            Set ts = FSO.CreateTextFile(SavePath, True)
            ts.Close
            Set ts = FSO.OpenTextFile(SavePath, IOMode:=ForAppending)
            ts.WriteLine (Now() & ";" & SenderName & ";" & senderit & ";" & GetSmtpAddress(Item) & ";" & sUserName & ";" & sHostName & "; ERROR")
            ts.Close
        Else
            Set ts = FSO.OpenTextFile(SavePath, IOMode:=ForAppending)
            ts.WriteLine (Now() & ";" & SenderName & ";" & senderit & ";" & GetSmtpAddress(Item) & ";" & sUserName & ";" & sHostName & "; ERROR")
            ts.Close
         End If
     End If
Set objRecip = Nothing






    If FSO.FileExists(SavePath) = False Then
        Set ts = FSO.CreateTextFile(SavePath, True)
        ts.Close
        Set ts = FSO.OpenTextFile(SavePath, IOMode:=ForAppending)
        ts.WriteLine ("Date" & ";" & "Sent on Behalf" & ";" & "Sender" & ";" & "Smtp Address" & ";" & "User Name" & ";" & "Host Name" & ";" & "Status")
        ts.WriteLine (Now() & ";" & SenderName & ";" & senderit & ";" & GetSmtpAddress(Item) & ";" & sUserName & ";" & sHostName & "; OK")
        ts.Close
    Else
        Set ts = FSO.OpenTextFile(SavePath, IOMode:=ForAppending)
        ts.WriteLine (Now() & ";" & SenderName & ";" & senderit & ";" & GetSmtpAddress(Item) & ";" & sUserName & ";" & sHostName & "; OK")
        ts.Close
    End If
Set FSO = Nothing
   
GetOut:
End Sub






Function GetSmtpAddress(mail As MailItem)
    On Error GoTo On_Error
    GetSmtpAddress = ""
    
    Dim Report As String
    Dim Session As Outlook.NameSpace
    Set Session = Application.Session
    


        Dim senderEntryID As String
        Dim sender As AddressEntry
        Dim PR_SENT_REPRESENTING_ENTRYID As String
        'Modified value URL TO SCHEMAS i'm new and forum don't allow full urls
        PR_SENT_REPRESENTING_ENTRYID = "URL TO 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
             'Modified value URL TO SCHEMAS i'm new and forum don't allow full urls
            PR_SMTP_ADDRESS = "URL TO SCHEMAS /mapi/ proptag/ 0x39FE001E"
            GetSmtpAddress = sender.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
        End If
            
        
   
    
Exiting:
        Exit Function
On_Error:
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting
    
End Function

What do you think about this code? How can i optimize it, i need to deploy this configuration to 30 computers.

[SamT]

Moderator bump

[skatonni]

You could if you wish set the SentOnBehalfOfName otherwise sender information is not available until the item is sent.

This may be sufficient for your purposes

senderit = Session.GetDefaultFolder(olFolderInbox).Parent