Intro
In
part 1 of Creating an Outlook Add-In I explained how to create an Outlook 2003 Add In. With this article,
I will use the same project and just use Outlook 2007 instead.
Design
I have decided to do things a bit differently with this article. If you recall, with the
first project, I made use of the Extensibility project template to create
the add-in. With this article, I selected File, New project, Visual Basic,
Office, 2007, Outlook 2007 Add-In. Short, sweet, simple. This gives a file
entitled ThisAddIn.vb. This is where we will write code almost identical to my
first project’s, with minor differences.
Figure 1 – Outlook Add-In
Code
ThisAddIn.vb Gives us the following methods:
- ThisAddIn_Startup
- ThisAddIn_Shutdown
We will use the Startup event to call our function(s) to add the button onto
the Outlook Toolbar, and we will use the Shutdown event to release all
resources. Not much of the code has changed, but the most differences comes with
creating the setup project.
Our code looks as follows:
Imports
Imports Microsoft.Office.Core 'Core Framework 'Imports Extensibility 'Ability to Extend Office Imports System.Runtime.InteropServices 'Interop Services Imports Microsoft.Office.Interop 'Office interop Imports System.Windows.Forms
Declarations
' Private WithEvents btnFunny As Office.CommandBarButton 'Our Command Button CHANGED HERE Private objAppObject As Outlook.Application = New Outlook.Application() 'Application Object CHANGED HERE Private objAddIn As Object 'Instance Private FunnyToolBarTag As String = "Save Your Funnies" Private FunnyToolBar As Office.CommandBar Private btnFunny As Office.CommandBarButton
BackupEmails Sub
'''Main Sub to Backup All Emails Sub BackupEmails() Try Dim i As Long 'First Loop - Folders Dim j As Long 'Second Loop - Subfolders Dim lngRemoveSlash As Long 'Name, After Unecessary \ Was Removed Dim strSubject As String 'Email Subject Dim strEmailName As String 'Email Name Dim strFileName As String 'Filename of Email Dim strPath As String 'Path Dim strSelFolder As String 'Selected Outlook Folder Dim strSelFolderPath As String 'Selected Outlook Folder Path Dim strSaveToFolder As String 'Where to Save to Dim outNameSpace As Outlook.NameSpace = New Outlook.NameSpace 'Outlook Namespace CHANGED HERE Dim objApp As Outlook.Application = New Outlook.Application() 'Outlook Application CHANGED HERE Dim objMailFolder As Outlook.MAPIFolder 'Outlook Mail Folder Dim objMailItem As Outlook.MailItem = New Outlook.MailItem 'Outlook Email Item CHANGED HERE Dim objFSO As Object 'File System Object Dim objFolderToBackup As Object 'Which Folder Must We Backup Dim colFolders As New Collection 'All Folders Dim colEntryID As New Collection 'All Entities Dim colStoreID As New Collection 'All Stores objFSO = CreateObject("Scripting.FileSystemObject") 'Create FSO Object objApp = New Outlook.Application 'Create Outlook Instance outNameSpace = objApp.GetNamespace("MAPI") 'Get Appropriate Outlook Namespace objFolderToBackup = outNameSpace.PickFolder 'Choose Folder to Backup If objFolderToBackup Is Nothing Then 'Nothing Selected Exit Sub End If strPath = CustomBrowseForFolder() 'Show & Get Output Folder If strPath = "" Then 'If No Path Chosen Exit Sub End If If Not Right(strPath, 1) = "\" Then 'Add \ Afterwards strPath = strPath & "\" End If Call GetOutLookFolders(colFolders, colEntryID, colStoreID, objFolderToBackup) 'Get All Folders For i = 1 To colFolders.Count 'Loop Through Folders strSelFolder = StripCharacters(colFolders(i)) 'Remove Characters that aren't Allowed in Filenames lngRemoveSlash = InStr(3, strSelFolder, "\") + 1 'Remove \ strSelFolder = Mid(strSelFolder, lngRemoveSlash, 256) 'Edited Filename strSelFolderPath = strPath & strSelFolder & "\" 'Add \ strSaveToFolder = Left(strSelFolderPath, Len(strSelFolderPath) - 1) & "\" 'Get Parent Folder of Message If Not objFSO.FolderExists(strSelFolderPath) Then 'If Folder doesn't Exist, Create it objFSO.CreateFolder(strSelFolderPath) End If objMailFolder = objApp.Session.GetFolderFromID(colEntryID(i), colStoreID(i)) 'Get All Subfolders in Chosen Folder For j = 1 To objMailFolder.Items.Count 'Establish Count objMailItem = objFolderToBackup.Items(j) 'Get Subfolder Items, ie, Emails in Folder strSubject = objMailItem.Subject 'Get Subject strEmailName = StripCharacters(strSubject) 'Strip Invalid Characters out of FileName strFileName = strSaveToFolder & strEmailName & ".msg" 'Name of Message to be Saved strFileName = Left(strFileName, 256) objMailItem.SaveAs(strFileName, 3) 'Save Next j Next i Catch ex As Exception MessageBox.Show(ex.Message.ToString()) End Try End Sub
GetOutLookFolders Sub
'''Get All Outlook Folders Sub GetOutLookFolders(ByVal colAllFolders As Collection, ByVal colAllEntryIDs As Collection, ByVal colAllStoreIDs As Collection, ByVal strSelFolder As Outlook.MAPIFolder) Try Dim strSubFolder As Outlook.MAPIFolder 'Get Chosen Folder colAllFolders.Add(strSelFolder.FolderPath) 'Path colAllEntryIDs.Add(strSelFolder.EntryID) 'Entry ID colAllStoreIDs.Add(strSelFolder.StoreID) 'Store ID For Each strSubFolder In strSelFolder.Folders 'Loop Through Folders GetOutLookFolders(colAllFolders, colAllEntryIDs, colAllStoreIDs, strSelFolder) 'Get Subfolders Next strSubFolder strSubFolder = Nothing 'Release Object Catch ex As Exception MessageBox.Show(ex.Message.ToString()) End Try End Sub
CustomBrowseForFolder Function
'''Display Browse for Folder Dialog Function CustomBrowseForFolder(Optional ByVal strDefaultLoc As String = "C:\Documents and Settings\hannes\Desktop\To Backup") As String Try Dim objShell As Object 'Shell Object objShell = CreateObject("Shell.Application"). _ CustomBrowseForFolder(0, "Please Choose a Folder to Backup", 0, strDefaultLoc) 'Create BFF Dialog CustomBrowseForFolder = objShell.self.Path 'Set Initial Path objShell = Nothing 'Release Object Catch ex As Exception MessageBox.Show(ex.Message.ToString()) End Try End Function
StripCharacters Function
'''Strip Invalid Characters from Subjects Function StripCharacters(ByVal strSubs As String) As String Try Dim objRegEx As Object 'Regular Expression Object objRegEx = CreateObject("vbscript.regexp") 'Create Regular Expression Object 'Regex Pattern to Identify Illegal Characters objRegEx.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]" objRegEx.IgnoreCase = True 'Ignore Case objRegEx.[Global] = True StripCharacters = objRegEx.Replace(strSubs, "") 'Replace Illegal Character with Empty String objRegEx = Nothing 'Release Reg Ex Object Catch ex As Exception MessageBox.Show(ex.Message.ToString()) End Try End Function
AddFunnyToolbar Sub
Private Sub AddFunnyToolbar() Try ' Delete the existing instance, if applicable. Dim ExistingFunnyToolBar As Office.CommandBar = DirectCast(Me.Application.ActiveExplorer().CommandBars.FindControl(vbNull, vbNull, FunnyToolBarTag, True), Office.CommandBar) If ExistingFunnyToolBar IsNot Nothing Then ExistingFunnyToolBar.Delete() End If ' Add a new toolbar to the ' CommandBars collection ' of the Explorer window. FunnyToolBar = Me.Application.ActiveExplorer().CommandBars.Add(FunnyToolBarTag, Office.MsoBarPosition.msoBarTop, False, True) If FunnyToolBar IsNot Nothing Then ' Add a button to the new toolbar. btnFunny = DirectCast(FunnyToolBar.Controls.Add(Office.MsoControlType.msoControlButton, vbNull, vbNull, 1, True), Office.CommandBarButton) btnFunny.Style = Office.MsoButtonStyle.msoButtonIconAndCaption btnFunny.Caption = "Save Your Funnies" btnFunny.FaceId = 1087 btnFunny.Tag = FunnyToolBarTag AddHandler btnFunny.Click, AddressOf btnFunny_Click btnFunny.Visible = True End If Catch ex As System.Exception System.Windows.Forms.MessageBox.Show("Error: " & ex.Message.ToString(), "Error Message") End Try End Sub
All the Events
Private Sub ThisAddIn_Startup(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Startup AddFunnyToolbar() End Sub Private Sub ThisAddIn_Shutdown(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Shutdown Try objAppObject = Nothing 'Remove Object References Catch ex As Exception MessageBox.Show(ex.Message.ToString()) End Try End Sub '''Click Event for Our Button Private Sub btnFunny_Click(ByVal Ctrl As Office.CommandBarButton, ByRef CancelDefault As Boolean) BackupEmails() 'Save Emails End Sub