Remember your Outlook settings
Using global variables, we can write VBA code that will "remember" its settings. The first time you run it, it will ask for values, then every subsequent iteration it will use the settings already provided.
For example, here is event code that moves incoming emails to another folder. The first time the event fires (i.e. the first email you receive after installing the code and restarting Outlook), it will ask you for the folder to move the emails. After that, the emails will automatically move without having to ask you each time. At least, until you restart Outlook!
Dim MyFolder As Outlook.MAPIFolder
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Set olApp = GetOutlookApp
Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim olApp As Outlook.Application
Dim Msg As Outlook.MailItem
If Not IsMail(item) Then GoTo ProgramExit
Set olApp = GetOutlookApp
Set Msg = item
' the first time this sub is run, MyFolder will = Nothing
' on subsequent executions, this will be skipped
' but it only lasts as long as Outlook is open!
If MyFolder Is Nothing Then
Set MyFolder = GetNS(olApp).PickFolder
End If
If Not MyFolder Is Nothing Then
Msg.Move MyFolder
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Set olApp = GetOutlookApp
Set Items = GetNS(olApp).GetDefaultFolder(olFolderInbox).Items
End Sub
Private Sub Items_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim olApp As Outlook.Application
Dim Msg As Outlook.MailItem
If Not IsMail(item) Then GoTo ProgramExit
Set olApp = GetOutlookApp
Set Msg = item
' the first time this sub is run, MyFolder will = Nothing
' on subsequent executions, this will be skipped
' but it only lasts as long as Outlook is open!
If MyFolder Is Nothing Then
Set MyFolder = GetNS(olApp).PickFolder
End If
If Not MyFolder Is Nothing Then
Msg.Move MyFolder
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.number & " - " & Err.Description
Resume ProgramExit
End Sub
Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Outlook.Application
End Function
Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
Set GetNS = app.GetNamespace("MAPI")
End Function
Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function
