I have the below vba coding in thisoutlooksession in outlook.
Basically this coding pops up a yes/no message box for all outgoing E-mails external to my organisation.
The coding works file, However, thisoutlooksession sometimes doesn't recognize that it has a coding in it.
However, when i open the coding window (Alt + F11) and place a break in the header, and run the coding, it starts working fine after that.
I have double/triple checked, there is no problem with the coding. it is something to do with the settings.
I have enabled all macros as well.
Any suggestions or thoughts as why this happens and how could this be overcome?
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
If Item.Class <> olMail Then Exit Sub
Dim sCompanyDomain As String: sCompanyDomain = "tell.com"
Const PidTagSmtpAddress As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
On Error Resume Next
Dim oMail As MailItem: Set oMail = Item
Dim oRecipients As Recipients: Set oRecipients = oMail.Recipients
Dim bDisplayMsgBox As Boolean: bDisplayMsgBox = False
Dim sExternalAddresses As String
Dim oRecipient As Recipient
For Each oRecipient In oRecipients
Dim oProperties As PropertyAccessor: Set oProperties = oRecipient.PropertyAccessor
Dim smtpAddress As String: smtpAddress = oProperties.GetProperty(PidTagSmtpAddress)
Debug.Print smtpAddress
If (Len(smtpAddress) >= Len(sCompanyDomain)) Then
If (Right(LCase(smtpAddress), Len(sCompanyDomain)) <> sCompanyDomain) Then
' external address found
If (sExternalAddresses = "") Then
sExternalAddresses = smtpAddress
Else
sExternalAddresses = sExternalAddresses & ", " & smtpAddress
End If
bDisplayMsgBox = True
End If
End If
Next
If (bDisplayMsgBox) Then
Dim iAnswer As Integer
iAnswer = MsgBox("You are about to send this email externally to " & sExternalAddresses & vbCr & vbCr & "Do you want to continue?", vbExclamation + vbYesNo + vbDefaultButton2, "External Email Check")
If (iAnswer = vbNo) Then
Cancel = True
End If
End If
End Sub
As a last resort move the otm file to a backup folder.
Start Outlook to find an empty otm. Copy the code above into ThisOutlookSession.
Related
I adapted code so I can reply to the latest email.
I loop through a range of cells in my spreadsheet to get a string to find the email in my inbox or sent items.
The code sometimes finds and opens the email thread and sometimes it won't.
Is the syntax of my filter correct?
searchString = "urn:schemas:httpmail:textdescription ci_phrasematch" & supNumber
I commented these lines otherwise it won't stop looping:
While searchComplete = False
' DoEvents
Wend
The event handler OutlookApp_AdvancedSearchComplete never fires
The following code is saved in a class module:
Option Explicit
' Credits: Based on this answer: https://stackoverflow.com/questions/31909315/advanced-search-complete-event-not-firing-in-vba
' Event handler for outlook
Dim WithEvents OutlookApp As Outlook.Application
Dim outlookSearch As Outlook.Search
Dim outlookResults As Outlook.Results
Dim searchComplete As Boolean
Private Declare Function GetTickCount Lib "Kernel32" () As Long
Sub Minuterie(Milliseconde As Long)
Dim Arret As Long
Arret = GetTickCount() + Milliseconde
Do While GetTickCount() < Arret
DoEvents
Loop
End Sub
' Handler for Advanced search complete
Private Sub OutlookApp_AdvancedSearchComplete(ByVal SearchObject As Search)
MsgBox "The AdvancedSearchComplete Event fired."
searchComplete = True
End Sub
Sub SearchAndReply(program_number As Range, searchFolderName As String, searchSubFolders As Boolean)
' Declare objects variables
Dim customMailItem As Outlook.MailItem
Dim searchString As String
Dim resultItem As Integer
Dim supNumber As String
Dim compName As String
Dim strFilter As String
Dim OutlookApp As Outlook.Application
Dim strTag As String
Dim answer As VbMsgBoxResult
' Variable defined at the class level
'Dim outlookSearch As Outlook.Search
Set OutlookApp = New Outlook.Application
strTag = "BodySearch"
' Variable defined at the class level (modified by outlookApp_AdvancedSearchComplete when search is completed)
searchComplete = False
supNumber = "'" & program_number.Value & "'"
searchString = "urn:schemas:httpmail:textdescription ci_phrasematch" & supNumber
' Perform advanced search
Set outlookSearch = OutlookApp.AdvancedSearch(searchFolderName, searchString, searchSubFolders)
Minuterie 2000
' Wait until search is complete based on outlookApp_AdvancedSearchComplete event
' While searchComplete = False
' DoEvents
' Wend
' Get the results
Set outlookResults = outlookSearch.Results
If outlookResults.Count = 0 Then
program_number.Interior.Color = vbRed
Exit Sub
End If
' Sort descending so you get the latest
outlookResults.Sort "[SentOn]", True
' Reply only to the latest one
resultItem = 1
' Some properties you can check from the email item for debugging purposes
On Error Resume Next
Debug.Print outlookResults.Item(resultItem).SentOn, outlookResults.Item(resultItem).ReceivedTime, outlookResults.Item(resultItem).SenderName, outlookResults.Item(resultItem).subject
On Error GoTo 0
Set customMailItem = outlookResults.Item(resultItem).ReplyAll
' At least one reply setting is required in order to replyall to fire
'customMailItem.Body = "Just a reply text " & customMailItem.Body
customMailItem.HTMLBody = "<p> Thank you <p>" & customMailItem.HTMLBody
customMailItem.Display
program_number.Interior.Color = vbYellow
End Sub
I saved the following code in regular module in Excel:
Public Sub ProcessEmails()
Dim testOutlook As Object
Dim oOutlook As clsOutlook
Dim searchRange As Range
Dim subjectCell As Range
Dim OGDD_Programs As Range
Dim searchFolderName As String
Dim answer As VbMsgBoxResult
Dim Sup_ENg_Number As Range
' Start outlook if it isn't opened (credits: https://stackoverflow.com/questions/33328314/how-to-open-outlook-with-vba)
On Error Resume Next
Set testOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0
If testOutlook Is Nothing Then
Shell ("OUTLOOK")
End If
' Initialize Outlook class
Set oOutlook = New clsOutlook
' Get the outlook inbox and sent items folders path (check the scope specification here: https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearch)
searchFolderName = "'" & Outlook.Session.GetDefaultFolder(olFolderInbox).FolderPath & "','" & Outlook.Session.GetDefaultFolder(olFolderSentMail).FolderPath & "'"
'
' ' Loop through excel cells with subjects
' Set searchRange = ThisWorkbook.Worksheets("Sheet1").Range("A2:A4")
'set a reference to cells we are going to loop through
Set OGDD_Programs = ActiveSheet.Range("A2", "A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeVisible)
For Each Sup_ENg_Number In OGDD_Programs
If (Sup_ENg_Number.Interior.Color = vbYellow Or Sup_ENg_Number.Interior.Color = vbRed) Then
Else
' Only to cells with actual subjects
If Sup_ENg_Number.Value <> vbNullString Then
Call oOutlook.SearchAndReply(Sup_ENg_Number, searchFolderName, True)
answer = MsgBox("Do you want to exit subRoutine ?", vbYesNo)
If answer = vbYes Then
Exit Sub
End If
End If
End If
Next Sup_ENg_Number
MsgBox "Search and reply completed"
' Clean object
Set testOutlook = Nothing
End Sub
'Then add a class module and name it: clsOutlook
Why do you need AdvancedSearch (which is asynchronous)? Use MAPIFolder.Items.Find. (where MAPIFolder is the folder you need to search, such as the Inbox retrieved using Application.Session.GetDEfaultFolder(olFolderInbox)).
The code should first check if Instant Search is enabled in the default store to determine whether to use the ci_phrasematch keyword for an exact phrase match of "keyword" in the item body, or the like keyword to match any occurrence of "keyword" as an exact string or a substring in the item body. For example:
Dim filter As String
If (Application.Session.DefaultStore.IsInstantSearchEnabled) Then
filter = "#SQL=" & Chr(34) _
& "urn:schemas:httpmail:textdescription" & Chr(34) _
& " ci_phrasematch 'office'"
Else
filter = "#SQL=" & Chr(34) _
& "urn:schemas:httpmail:textdescription" & Chr(34) _
& " like '%office%'"
End If
The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Read more about that in the Advanced search in Outlook programmatically: C#, VB.NET article.
Re: The event handler OutlookApp_AdvancedSearchComplete never fires.
I have to work around this event.
Option Explicit
Private Sub Get_LastMail_AdvSearch_URN_Subject()
Dim strSearch As String
Dim strFilter As String
Dim strScope As String
Dim objSearch As Search
Dim fldrNm As String
Dim rsts As results
Dim rstObj As Object
Debug.Print
strScope = "'Inbox', 'Sent Items', 'Deleted Items'"
'strScope = "'Inbox', 'Sent Items'"
Debug.Print "strScope............: " & strScope
strSearch = "test"
fldrNm = "Subject: " & strSearch
Debug.Print fldrNm
strFilter = "urn:schemas:httpmail:subject LIKE '%" & strSearch & "%'"
Debug.Print strFilter
Set objSearch = AdvancedSearch(scope:=strScope, Filter:=strFilter, SearchSubFolders:=True, Tag:="SearchFolder")
' The Application.AdvancedSearchComplete event is problem
' https://learn.microsoft.com/en-us/office/vba/api/outlook.application.advancedsearchcomplete
' https://stackoverflow.com/questions/31909315/advanced-search-complete-event-not-firing-in-vba
' Saving may be enough. This would be ideal but not on my machine.
' You may have to delete a previously generated search folder before subsequent runs
objSearch.Save fldrNm
DoEvents
Debug.Print fldrNm & " saved."
Set rsts = objSearch.results
Debug.Print " rsts.Count: " & rsts.Count
If rsts.Count = 0 Then
Debug.Print "Delay initiated."
' Delay to allow the search to complete
Dim waitTime As Long
Dim delay As Date
' Will surely be too little at the most inopportune time
waitTime = 1 ' in seconds - adjust as needed
Debug.Print vbCr & "Wait start: " & Now
delay = DateAdd("s", waitTime, Now)
Debug.Print "Wait until: " & delay
Do Until Now > delay
DoEvents
Loop
End If
Set rsts = objSearch.results
Debug.Print " rsts.Count: " & rsts.Count
If rsts.Count > 0 Then
rsts.Sort "[ReceivedTime]", True
Set rstObj = rsts(1)
Debug.Print rstObj.subject
Else
Debug.Print "no items found."
End If
End Sub
I'm working on a macro which checks the attachment name against the subject name and the domain.
At the moment there's a couple of minor issues, I don't want the macro to recognise images in the signature as an attachment. Solutions I've seen include using an if statement to work out the size, so for example only check attachments over 5kb etc.
The other issue is, if there is no attachment at all, the macro falls over! I think I need another if statement in there at the end to do an item count but I'm not sure how that alters my conditions at the end of the macro!
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim outRecips As Outlook.Recipients
Dim outRecip As Outlook.Recipient
Dim outPropAcc As Outlook.PropertyAccessor
Dim strDomain As String
Dim lngPreDom As Long
Dim lngPostDom As Long
Dim strSubject As String
Dim objAttachments As Outlook.Attachments
Dim strAttachment As String
Dim Response As String
' set domain value
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set outRecips = Item.Recipients
For Each outRecip In outRecips
Set outPropAcc = outRecip.PropertyAccessor
strDomain = outPropAcc.GetProperty(PR_SMTP_ADDRESS)
strDomain = Split(strDomain, "#")(1)
lngPreDom = InStr(strDomain, "#")
lngPostDom = InStr(strDomain, ".")
strDomain = LCase(Mid(strDomain, lngPreDom + 1, lngPostDom - lngPreDom - 1))
Exit For
Next
' set subject value
strSubject = LCase(Item.Subject)
' set attachment name
Set objAttachments = Item.Attachments
strAttachment = LCase(objAttachments.Item(1).FileName)
' if external recipient, check email contents
If strDomain <> "exampleemail" _
Then
If InStr(strSubject, strDomain) = 0 _
Or InStr(strAttachment, strDomain) = 0 _
Or InStr(strAttachment, strSubject) = 0 _
Then
Response = "Attachment/Subject do not match Recipient(s)" & vbNewLine & "Send Anyway?"
If MsgBox(Response, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Recipients") = vbNo Then
Cancel = True
End If
End If
End If
End Sub
Use the Attachment.PropertyAccessor object to read the PR_ATTACHMENT_HIDDEN property (http://schemas.microsoft.com/mapi/proptag/0x7FFE000B); if it's true it's an embedded image (usually in signatures).
I need to automatically save an attachment depending on what email it was sent to (not by senders).
I have 3 emails on the mail server pdf#, xml#, txt#. If email is sent to #pdf I need to save it on a network drive, and same goes for the other emails but to different locations.
All other code I have seen only take into account the sender not the sent to address.
You can handle the ItemSend event of the Application class where you can check out the To address (or the Recipients collection) and save the attachment if required. For example:
Public WithEvents myOlApp As Outlook.Application
Public Sub Initialize_handler()
Set myOlApp = Outlook.Application
End Sub
Private Sub myOlApp_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim prompt As String
prompt = "Are you sure you want to send " & Item.Subject & "?"
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
Cancel = True
End If
End Sub
The ItemSend event is fired whenever an Microsoft Outlook item is sent, either by the user through an Inspector (before the inspector is closed, but after the user clicks the Send button) or when the Send method for an Outlook item, such as MailItem, is used in a program.
You may find the Getting Started with VBA in Outlook 2010 article helpful.
Created 3x postlists and one rule in Outlook.
When email is sent to (add all the postlists) and has an attachment
run this script. ps. you have to edit all of the paths, foldernames and postlistnames.
Sub SaveAllAttachments(objitem As MailItem)
Dim objAttachments As Outlook.Attachments
Dim strName, strLocation As String
Dim dblCount, dblLoop As Double
Dim strSub As String
Dim iRcpCount, iRcp As Integer
strLocation = "O:\PDF\"
On Error GoTo ExitSub
If objitem.Class = olMail Then
Set objAttachments = objitem.Attachments
dblCount = objAttachments.Count
If dblCount <= 0 Then
GoTo 100
End If
strSub = ""
iRcpCount = objitem.Recipients.Count
For iRcp = 1 To iRcpCount
If objitem.Recipients(iRcp).Name = "Postlist1" Then
strSub = "Folder1onOdrive"
ElseIf objitem.Recipients(iRcp).Name = "Postlist2" Then
strSub = "Folder2onOdrive"
ElseIf objitem.Recipients(iRcp).Name = "Postlist3" Then
strSub = "Folder3onOdrive"
End If
Next iRcp
For dblLoop = 1 To dblCount
strName = objAttachments.Item(dblLoop).FileName
'strName = strLocation & strName
strName = strLocation & strSub & strName
'strName = strLocation & strName
objAttachments.Item(dblLoop).SaveAsFile strName
Next dblLoop
objitem.Delete
End If
100
ExitSub:
Set objAttachments = Nothing
Set objOutlook = Nothing
End Sub
Personal identifying information (PII) is often inadvertently transmitted through non-encrypted emails. Most of the times these data are stored in Excel or Access spreadsheets.
I'd like to identify Access or Excel attachments after hitting send and ask "There are Access or Excel files attached to this email, are you sure these do not contain PII?"
The criteria for identifying "xlsx" or "accdb" in the attachment name I just don't get.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If Right([attachment_Name],4) = xlsx then
answer = MsgBox("There are Access or Excel files attached to this email, are you sure these do not contain PHI?",vbYesNo)
If answer = vbNo
Cancel = True
Else
End If
End If
End Sub
Here's the code you're looking for:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim bolSensitiveAttach As Boolean
Dim answer As Double
Set Msg = Item
bolSensitiveAttach = False
If Msg.Attachments.Count > 0 Then
For i = 1 To Msg.Attachments.Count
If Right(Msg.Attachments(i).FileName, 3) = "xls" Or _
Left(Right(Msg.Attachments(i).FileName, 4), 3) = "xls" Or _
Right(Msg.Attachments(i).FileName, 5) = "accdb" Or _
Right(Msg.Attachments(i).FileName, 3) = "mdb" Then
bolSensitiveAttach = True
End If
Next i
End If
If bolSensitiveAttach = True Then
answer = MsgBox("There are Access or Excel files attached to this" _
& "mail, are you sure these do not contain PHI?", vbYesNo)
If answer = vbNo Then
Cancel = True
End If
End If
End Sub
Hope this helps.
EDITED TO INCLUDE .mdb extension and xls* extensions (xlsm, xlsx...) instead of just xlsx. Thanks for the suggestion Parfait.
You could use the FileSystemObject to grab the extension:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim olAtt As Attachment
Dim oFSO As Object
Dim sExt As String
Dim bSafe As Boolean
If Item.Attachments.Count > 0 Then
bSafe = True
Set oFSO = CreateObject("Scripting.FileSystemObject")
For Each olAtt In Item.Attachments
sExt = oFSO.GetExtensionName(olAtt.FileName)
If sExt Like "xls*" Or sExt Like "accd*" Or sExt = "mdb" Then
bSafe = False
Exit For
End If
Next olAtt
If Not bSafe Then
If MsgBox("This email contains an Access or Excel file." & vbCr & _
"Do you wish to continue?", vbCritical + vbYesNo) = vbNo Then
Cancel = True
End If
End If
Set oFSO = Nothing
End If
End Sub
I've included for Access, but pretty sure that doesn't send by default.
I recently completed an outlook vba script that will scan the subject line of each mailitem added to the sent folder, looking for a project number in the subject. When detected, the script extracts the project number, creates a copy of the mailitem and then moves that copy to shared mailbox folders based on the project number (performing folder checks first). I currently have it setup to create a copy of the mail item first, then move that copy to the new folder destination. This is so the original sent mailitem is left alone in the Sent Folder and not removed.
The problem I've come across is when the script creates a copy of the mail item within the sent folder, it triggers a new instance of the script (since it runs when a new item is added to the sent folder) and will repeat this process indefinitely, creating and moving copies until Outlook is forced closed. Adding a loop count check doesn't seem to help because the script starts from scratch each time an item is added.
Below is the full code, is there a better way to approach this than I'm currently doing? Any insight or direction will be greatly appreciated!
Edit: Forgot to add I have this code pasted in my Outlook's ThisOutlookSession in the vb developer tab (VbaProject.OTM file)
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
Set Items = GetNS(olApp).GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error Resume Next
MsgBox "Mail Added to Sent Folder, Checking for T-#"
Dim EmailSub As String
Dim EmailSubArr As Variant
Dim ProjectNum As String
Dim FullProjectNum As String
Dim ProjNumLen As Long
Dim ParentFolderName As String
Dim SubFolderName As String
If TypeName(item) = "MailItem" Then
'Checks Email Subject for Project Number Tag
If InStr(item.Subject, "T-") > 0 Then
MsgBox "T-# Detected"
'Splits out Project Number into an Array for Extraction
EmailSub = item.Subject
EmailSubArr = Split(EmailSub, Chr(32))
For i = LBound(EmailSubArr) To UBound(EmailSubArr)
If InStr(EmailSubArr(i), "T-") > 0 Then
FullProjectNum = EmailSubArr(i)
MsgBox "T-# Extracted"
ProjNumLen = Len(FullProjectNum)
MsgBox ("T-# is " & ProjNumLen & " Characters Long")
'Project Number Length Check and Formatting
If ProjNumLen >= 11 Then
Exit Sub
End If
If ProjNumLen <= 6 Then
Exit Sub
End If
If ProjNumLen = 10 Then
'Really Extended T-# Format 1(ie T-38322X12)
ProjectNum = Right(FullProjectNum, 8)
ParentFolderName = Left(ProjectNum, 2)
SubFolderName = Left(ProjectNum, 8)
End If
If ProjNumLen = 9 Then
'Extended T-# Format 1(ie T-38322X1)
ProjectNum = Right(FullProjectNum, 7)
ParentFolderName = Left(ProjectNum, 2)
SubFolderName = Left(ProjectNum, 7)
End If
If ProjNumLen = 8 Then
'Uncommon T-# Format (ie T-38322A)
ProjectNum = Right(FullProjectNum, 6)
ParentFolderName = Left(ProjectNum, 2)
SubFolderName = Left(ProjectNum, 6)
End If
If ProjNumLen = 7 Then
'Standard T-# Format (ie T-38322)
ProjectNum = Right(FullProjectNum, 5)
ParentFolderName = Left(ProjectNum, 2)
SubFolderName = Left(ProjectNum, 5)
End If
Exit For
End If
Next i
MsgBox ("Confirm Extraction (1 of 3) - Project Number is T-" & ProjectNum)
MsgBox ("Confirm Extraction (2 of 3) - Parent Folder Will Be " & ParentFolderName)
MsgBox ("Confirm Extraction (3 of 3) - Sub Folder Will Be " & SubFolderName)
MsgBox ("Will Now Perform Folder Checks")
'Perform Folder Checks, Creates Folders When Needed
Dim fldrparent As Outlook.MAPIFolder
Dim fldrsub As Outlook.MAPIFolder
Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName)
Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
If fldrparent Is Nothing Then
MsgBox "Parent Folder Does Not Exist, Creating Folder"
Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders.Add(ParentFolderName)
Else
MsgBox "Parent Folder Already Exists, Do Nothing"
End If
If fldrsub Is Nothing Then
MsgBox "Sub Folder Does Not Exist, Creating Folder"
Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders.Add(SubFolderName)
Else
MsgBox "Sub Folder Already Exists, Do Nothing"
End If
'Moves Copy of Email to Folder
MsgBox "Copying Sent Email to Project Folder"
Dim FolderDest As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myCopiedItem As Outlook.MailItem
Set FolderDest = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
'Set myCopiedItem = item.Copy
item.Move FolderDest
Else
MsgBox "Did not detect T-##### project number"
End If
End If
ProgramExit:
Exit Sub
End Sub
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function
Add module level variable e.g. 'm_cancelAdd' and set its value to true before Item.Copy. At the very beginnig of the ItemAdd event handler check the value of m_cancelAdd and if it is true then reset it and exit the handler. HTH.
Private WithEvents Items As Outlook.Items
Private m_cancelAdd As Boolean
Private Sub Items_ItemAdd(ByVal Item As Object)
If (m_cancelAdd) Then
m_cancelAdd = False
Exit Sub
End If
Dim myCopiedItem As Outlook.MailItem
Dim FolderDest
m_cancelAdd = True
Set myCopiedItem = Item.Copy
Debug.Print "Item copy created..."
Set FolderDest = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
Item.Move FolderDest
End Sub
You can set you own special property on the new message using MailItem.UserProperties before you save it. You can then check if that property exists (MailItem.UserProperties.Find) when ItemAdd event fires and skip the item if the property is set.
Instead of ItemAdd try Application_ItemSend.
http://msdn.microsoft.com/en-us/library/office/ff865076(v=office.14).aspx
It is simpler than it looks. In the ThisOutlookSession module.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' your code here
End Sub
You can test it with the example provided in the link.
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim prompt As String
prompt = "Are you sure you want to send " & Item.Subject & "?"
If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
Cancel = True
End If
End Sub