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