Preventing Users Moving/Deleting Folders - BeforeFolderMove event? Outlook 2007

[Graham_T]

Hi,

I have inherited some processes which run in Outlook and certain code relies on Outlook folders being present as mails are processed and moved automatically to these particular folders.

The folder structure looks like the following example:

10594

I need to prevent the E3 Imported and E3 Manual folders from being moved/deleted and from searching there does not appear to be an interface way of preventing this, so understand this would need to be done in code.

My current code looks like this:


Option Explicit
Public ns As NameSpace
Public WithEvents mailFeed As Items
Public WithEvents iBillingTeam As Items

'// Billing Team Rules added 02/01/2013
Public WithEvents iBillingTeamRules As Items

'// 07/03/2013 Auto E3 Test
Public WithEvents EIEInbox As Items
Public WithEvents NRWInbox As Items
Public WithEvents SSCInbox As Items

Public NRW As Outlook.MAPIFolder
Public EIE As Outlook.MAPIFolder
Public SSC As Outlook.MAPIFolder

Public Sub application_Startup()
Dim debugMode As Boolean
debugMode = False
If debugMode = False Then
On Error GoTo ErrorHandle
End If
Set ns = Application.GetNamespace("MAPI")
Set mailFeed = ns.GetDefaultFolder(olFolderInbox).Items
Set iBillingTeam = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Status Message").Items

Set EIE = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Teams").Folders("East & Ireland").Folders("1 - Inbox")
Set NRW = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Teams").Folders("North & West").Folders("1 - Inbox")
Set SSC = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Teams").Folders("South & Scotland").Folders("1 - Inbox")

'// Billing Teams Rules 02/01/2013
Set iBillingTeamRules = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Inbox").Items

'// 07/03/2013 E3 Test
Set EIEInbox = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Teams").Folders("East & Ireland").Folders("1 - Inbox").Items
Set NRWInbox = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Teams").Folders("North & West").Folders("1 - Inbox").Items
Set SSCInbox = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Teams").Folders("South & Scotland").Folders("1 - Inbox").Items
sEmailSubject = ""
Exit Sub
ErrorHandle:
Select Case Err.Number
Case -2147221219
'// Network problem with exchange
Debug.Print "There is a network problem, code may not work"
Resume Next
Case Else
MsgBox ("error in application_Startup: " & Err.Number & " - " & Err.Description & vbCrLf _
& "Use debugMode=True to see where the error is")
Resume Next
End Select
End Sub


I have located some code example online from a book Microsoft Outlook 2007 Programming: Jumpstart for Power Users and Administrators By Sue Mosher: (sorry, can't post link as not enough posts):


Dim WithEvents objCritFolder As Outlook.Folder
Private Sub application_startup()
Dim objRootFolder As Outlook.Folder
Set objRootFolder = _
Application.Session.DefaultStore.GetRootFolder
Set objCritFolder = objRootFolder.Folders("Critical")
Set objInbox = Nothing
Set objRootFolder = Nothing
End Sub
Private Sub objCritFolder_BeforeFolderMove(ByVal MoveTo As MAPIFolder, cancel As Boolean)
Dim strMsg As String
cancel = True
strMsg = "You can't delete the Critical folder."
MsgBox strMsg, vbCritical, "Folder Move Not Allowed"
End Sub


but am unsure how to implement this within the code that I have (sorry, Outlook is not something I have used code in previously, so a little out of my depth!)

Thanks for any assistance you can provide.

GT

[skatonni]

To prevent yourself from moving folders place this in your VBA project:



Public WithEvents objCritFolder_EIE_E3Imp As Outlook.MAPIFolder
Public WithEvents objCritFolder_EIE_E3Man As Outlook.MAPIFolder

Private Sub application_Startup()

' …

Set SSCInbox = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Teams").Folders("South & Scotland").Folders("1 - Inbox").Items
sEmailSubject = ""

application_Startup_Protect ' <---

Exit Sub
ErrorHandle:

' …

End Sub

Public Sub application_Startup_Protect()
Dim ns As Namespace
Dim objRootFolder As Outlook.MAPIFolder

Set ns = Application.GetNamespace("MAPI")

Set objRootFolder = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Teams").Folders("East & Ireland")
Set objCritFolder_EIE_E3Imp = objRootFolder.Folders("E3 Imported")
Set objCritFolder_EIE_E3Man = objRootFolder.Folders("E3 Manual")
Set objRootFolder = Nothing
End Sub

Private Sub objCritFolder_EIE_E3Imp_BeforeFolderMove(ByVal MoveTo As MAPIFolder, cancel As Boolean)
Dim strMsg As String
cancel = True
strMsg = "You can't move the E3 Imported folder."
MsgBox strMsg, vbCritical, "Folder Move Not Allowed"
End Sub
Private Sub objCritFolder_EIE_E3Man_BeforeFolderMove(ByVal MoveTo As MAPIFolder, cancel As Boolean)
Dim strMsg As String
cancel = True
strMsg = "You can't move the E3 Manual folder."
MsgBox strMsg, vbCritical, "Folder Move Not Allowed"
End Sub


To prevent others from moving folders place this in their VBA project:

Public WithEvents objCritFolder_EIE_E3Imp As Outlook.MAPIFolder
Public WithEvents objCritFolder_EIE_E3Man As Outlook.MAPIFolder

Private Sub application_Startup()
Dim ns As Namespace
Dim objRootFolder As Outlook.MAPIFolder

Set ns = Application.GetNamespace("MAPI")

Set objRootFolder = ns.Folders("MailBox - The Danwood Group Ltd [Billing Team]").Folders("Teams").Folders("East & Ireland")
Set objCritFolder_EIE_E3Imp = objRootFolder.Folders("E3 Imported")
Set objCritFolder_EIE_E3Man = objRootFolder.Folders("E3 Manual")
Set objRootFolder = Nothing
End Sub

Private Sub objCritFolder_EIE_E3Imp_BeforeFolderMove(ByVal MoveTo As MAPIFolder, cancel As Boolean)
Dim strMsg As String
cancel = True
strMsg = "You can't move the E3 Imported folder."
MsgBox strMsg, vbCritical, "Folder Move Not Allowed"
End Sub
Private Sub objCritFolder_EIE_E3Man_BeforeFolderMove(ByVal MoveTo As MAPIFolder, cancel As Boolean)
Dim strMsg As String
cancel = True
strMsg = "You can't move the E3 Manual folder."
MsgBox strMsg, vbCritical, "Folder Move Not Allowed"
End Sub

[Graham_T]

Thanks very much for the response.

I attempted to add this, however recieve the attached error message 'Object does not source automation events'

10615

Can you advise why this may be?

GT

[SamT]

I'm not familiar with the Outlook VBA Object Model, but in other Applications, the Application_StartUp sub would need to be in the Application's Object module, (ThisWorkbook, ThisDocument, etc,) and the rest of that code would have to be in a Class Module.

YMMV

[Graham_T]

Sam,

Thanks, but I'm completely unsure of this. This is an inherited process, with all the current code in place, so I wouldn't like to change too much for fear of breaking processes!