C
couerdelion
Hi
I'm having a problem when moving mail.
When the mail is not flagged "Do not Forward" then the code is invoked.
If the user has used a local distribution list then it cycles through
the list and adds the individual addresses to the bcc field. This
ensures the Team Leader has the up to date Distribution list that the
administrator has.
Stepping through the code on a user machine the list is populated
perfectly and before the mail is sent I can see the BCC field
populated. The copy moved to the shared folder however doesn't contain
the BCC list though, although there is a copy in the users deleted
items folder that does contain the BCC list.
For some reason it doesn't seem to be updating the item correctly and I
don't know why. It's almost like it updating a byval reference and then
sending the byref reference(unchanged) if that makes sense? It works
fine on my machine and the managers machine too.
Anyone any ideas?
'*****************************************************************************************
'*
'* Author: Richard Hart
'*
'* Created: 7th September 2006
'*
'* Description: Check if an email contains certain words.
'* If so then checks any attachments and looks up the correct
recipients.
'* The mail is then placed in a designated folder to be sent on
by a Team Leader
'*
'*
'*
'*****************************************************************************************
Option Explicit
Public WithEvents SentItemsAdd As Items
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As
Boolean)
Dim olns As Outlook.NameSpace 'Outlook
Dim bccstring As String 'String for email adresses from paxus
Dim mycopy As Object 'to hold copy of email
Dim icount As Integer 'Private counter
Dim oSubFolder As Outlook.MAPIFolder 'MapiFolder
Dim oPublicFolders As Outlook.MAPIFolder 'Public folders
Dim bExternal As Boolean
Dim dcount As Integer
Dim xCount As Integer
Dim sMails As String
On Error GoTo ErrHandler
'Is the message flag set to Do not Forward ?
'We use this to send emails without the checking being invoked
If UCase(Item.FlagRequest) <> "DO NOT FORWARD" Then
'Is this an internal mail?
icount = 0
bExternal = False
For icount = 1 To Item.Recipients.Count
If Item.Recipients.Item(icount).DisplayType = 5 Then
For xCount = 1 To
Item.Recipients.Item(icount).AddressEntry.Members.Count
sMails =
Item.Recipients.Item(icount).AddressEntry.Members.Item(xCount).Address
Dim objMe As Recipient
Set objMe = Item.Recipients.Add(sMails)
objMe.Type = olBCC
objMe.Resolve
Set objMe = Nothing
Next
'Item.Recipients.Item(icount).Delete
'Item.Recipients.Add sMails
sMails = ""
End If
'Save item
Item.Save
Next
For icount = 1 To Item.Recipients.Count
If InStr(Item.Recipients.Item(icount).Address, "@") > 0 Then
'external address
bExternal = True
Else
'Do nothing
End If
Next
If bExternal = False Then Exit Sub
If InStr(UCase(Item.Subject), "SHARE REGISTRY CONFIRMATION") > 0 Or
InStr(UCase(Item.Subject), "VALUATION SUMMARY REPORT") > 0 Then
Exit Sub
End If
'Flag is not set so has the message got a subject or message body
containing
'any of the reserved words?
If InStr(UCase(Item.Subject), "ASSET") > 0 Or
InStr(UCase(Item.Body), "ASSET") Then
'Reserved words found!
'first stop the message from being sent.
Cancel = True
GoTo MoveMail
End If
'Do we have an attachment?
If Item.Attachments.Count > 0 Then
'Loop round the attachments looking for an xls file or reserved
word
For icount = 1 To Item.Attachments.Count
'is the attachment one we stop?
If InStr(UCase(Item.Attachments(icount)), "SHARE REGISTRY
CONFIRMATION") > 0 Or InStr(UCase(Item.Attachments(icount)), "VALUATION
SUMMARY REPORT") > 0 Then
'Do nothing
Else
'We want to stop it
'First stop the message from being sent.
Cancel = True
'Attachment(s) found. reset our internal counter
icount = 1
End If
'Does the attachment contain an .xls extension
If Right(Item.Attachments(icount), 3) = "xls" Then
'If so go get the recipients from the routine
If InStr(Item.Attachments(icount), "_") > 0 Then
bccstring =
GetBccString(Left(Item.Attachments(icount),
InStr(Item.Attachments(icount), "_") - 1))
End If
'Have we got an address?
If Len(Trim(bccstring)) > 4 Then
'Set all the recipient fields to blank. this mail
is only allowed to be sent to the
'recipients identified from the counterpart table.
Item.To = ""
Item.CC = ""
Item.BCC = ""
'Set the bcc field to what we've just recovered.
Item.BCC = bccstring
'found so exit loop
Exit For
End If
End If
'not found so move next
Next
'If no recipient is found the mail will still be moved. It
will however
'contain the original to, cc & bcc
Else
Exit Sub
End If
MoveMail:
If Cancel = False Then Exit Sub
'Set the variable to our local namespace
Set olns = GetNamespace("MAPI")
'Set the folder to copy to
Set oSubFolder = olns.Folders("Public Folders").Folders("All
Public Folders").Folders("SS Pending")
' Set oSubFolder2 = olns.Folders("Public Folders").Folders("All
Public Folders").Folders("SS Pending")
'Set the flag so subsequent sends miss this routine
Item.FlagRequest = "Do not Forward"
Item.Save
'make a copy of the mail
'Set mycopy = Item.Copy
'move the copy of the mail
'mycopy.Move oSubFolder
Item.Move oSubFolder
'Reset the subfolder
Set oSubFolder = Nothing
'delete the original mail
Item.Delete
'Lets tell the user what we've done!
MsgBox "Reserved words found." & vbCrLf & vbCrLf & "Mail
forwarded for approval." & vbCrLf & vbCrLf & "Please talk to your
superior if more information is required.", vbCritical, "Your attention
is required!"
Else
'Reset the flag before we send
Item.FlagRequest = ""
End If
Exit Sub
ErrHandler:
MsgBox "An error has occurred in the Application.Itemsend routine." &
vbCrLf & "Error number = " & Err.Number & vbCrLf & "The description for
this error is: " & vbCrLf & Err.Description & vbCrLf & _
"Please contact a member of IT who will resolve this problem."
Exit Sub
Resume
End Sub
Private Sub Application_MAPILogonComplete()
'Get the default outbox
Set SentItemsAdd =
Application.GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox).Items
End Sub
I'm having a problem when moving mail.
When the mail is not flagged "Do not Forward" then the code is invoked.
If the user has used a local distribution list then it cycles through
the list and adds the individual addresses to the bcc field. This
ensures the Team Leader has the up to date Distribution list that the
administrator has.
Stepping through the code on a user machine the list is populated
perfectly and before the mail is sent I can see the BCC field
populated. The copy moved to the shared folder however doesn't contain
the BCC list though, although there is a copy in the users deleted
items folder that does contain the BCC list.
For some reason it doesn't seem to be updating the item correctly and I
don't know why. It's almost like it updating a byval reference and then
sending the byref reference(unchanged) if that makes sense? It works
fine on my machine and the managers machine too.
Anyone any ideas?
'*****************************************************************************************
'*
'* Author: Richard Hart
'*
'* Created: 7th September 2006
'*
'* Description: Check if an email contains certain words.
'* If so then checks any attachments and looks up the correct
recipients.
'* The mail is then placed in a designated folder to be sent on
by a Team Leader
'*
'*
'*
'*****************************************************************************************
Option Explicit
Public WithEvents SentItemsAdd As Items
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As
Boolean)
Dim olns As Outlook.NameSpace 'Outlook
Dim bccstring As String 'String for email adresses from paxus
Dim mycopy As Object 'to hold copy of email
Dim icount As Integer 'Private counter
Dim oSubFolder As Outlook.MAPIFolder 'MapiFolder
Dim oPublicFolders As Outlook.MAPIFolder 'Public folders
Dim bExternal As Boolean
Dim dcount As Integer
Dim xCount As Integer
Dim sMails As String
On Error GoTo ErrHandler
'Is the message flag set to Do not Forward ?
'We use this to send emails without the checking being invoked
If UCase(Item.FlagRequest) <> "DO NOT FORWARD" Then
'Is this an internal mail?
icount = 0
bExternal = False
For icount = 1 To Item.Recipients.Count
If Item.Recipients.Item(icount).DisplayType = 5 Then
For xCount = 1 To
Item.Recipients.Item(icount).AddressEntry.Members.Count
sMails =
Item.Recipients.Item(icount).AddressEntry.Members.Item(xCount).Address
Dim objMe As Recipient
Set objMe = Item.Recipients.Add(sMails)
objMe.Type = olBCC
objMe.Resolve
Set objMe = Nothing
Next
'Item.Recipients.Item(icount).Delete
'Item.Recipients.Add sMails
sMails = ""
End If
'Save item
Item.Save
Next
For icount = 1 To Item.Recipients.Count
If InStr(Item.Recipients.Item(icount).Address, "@") > 0 Then
'external address
bExternal = True
Else
'Do nothing
End If
Next
If bExternal = False Then Exit Sub
If InStr(UCase(Item.Subject), "SHARE REGISTRY CONFIRMATION") > 0 Or
InStr(UCase(Item.Subject), "VALUATION SUMMARY REPORT") > 0 Then
Exit Sub
End If
'Flag is not set so has the message got a subject or message body
containing
'any of the reserved words?
If InStr(UCase(Item.Subject), "ASSET") > 0 Or
InStr(UCase(Item.Body), "ASSET") Then
'Reserved words found!
'first stop the message from being sent.
Cancel = True
GoTo MoveMail
End If
'Do we have an attachment?
If Item.Attachments.Count > 0 Then
'Loop round the attachments looking for an xls file or reserved
word
For icount = 1 To Item.Attachments.Count
'is the attachment one we stop?
If InStr(UCase(Item.Attachments(icount)), "SHARE REGISTRY
CONFIRMATION") > 0 Or InStr(UCase(Item.Attachments(icount)), "VALUATION
SUMMARY REPORT") > 0 Then
'Do nothing
Else
'We want to stop it
'First stop the message from being sent.
Cancel = True
'Attachment(s) found. reset our internal counter
icount = 1
End If
'Does the attachment contain an .xls extension
If Right(Item.Attachments(icount), 3) = "xls" Then
'If so go get the recipients from the routine
If InStr(Item.Attachments(icount), "_") > 0 Then
bccstring =
GetBccString(Left(Item.Attachments(icount),
InStr(Item.Attachments(icount), "_") - 1))
End If
'Have we got an address?
If Len(Trim(bccstring)) > 4 Then
'Set all the recipient fields to blank. this mail
is only allowed to be sent to the
'recipients identified from the counterpart table.
Item.To = ""
Item.CC = ""
Item.BCC = ""
'Set the bcc field to what we've just recovered.
Item.BCC = bccstring
'found so exit loop
Exit For
End If
End If
'not found so move next
Next
'If no recipient is found the mail will still be moved. It
will however
'contain the original to, cc & bcc
Else
Exit Sub
End If
MoveMail:
If Cancel = False Then Exit Sub
'Set the variable to our local namespace
Set olns = GetNamespace("MAPI")
'Set the folder to copy to
Set oSubFolder = olns.Folders("Public Folders").Folders("All
Public Folders").Folders("SS Pending")
' Set oSubFolder2 = olns.Folders("Public Folders").Folders("All
Public Folders").Folders("SS Pending")
'Set the flag so subsequent sends miss this routine
Item.FlagRequest = "Do not Forward"
Item.Save
'make a copy of the mail
'Set mycopy = Item.Copy
'move the copy of the mail
'mycopy.Move oSubFolder
Item.Move oSubFolder
'Reset the subfolder
Set oSubFolder = Nothing
'delete the original mail
Item.Delete
'Lets tell the user what we've done!
MsgBox "Reserved words found." & vbCrLf & vbCrLf & "Mail
forwarded for approval." & vbCrLf & vbCrLf & "Please talk to your
superior if more information is required.", vbCritical, "Your attention
is required!"
Else
'Reset the flag before we send
Item.FlagRequest = ""
End If
Exit Sub
ErrHandler:
MsgBox "An error has occurred in the Application.Itemsend routine." &
vbCrLf & "Error number = " & Err.Number & vbCrLf & "The description for
this error is: " & vbCrLf & Err.Description & vbCrLf & _
"Please contact a member of IT who will resolve this problem."
Exit Sub
Resume
End Sub
Private Sub Application_MAPILogonComplete()
'Get the default outbox
Set SentItemsAdd =
Application.GetNamespace("MAPI").GetDefaultFolder(olFolderOutbox).Items
End Sub