Creating an Outlook Add-In Part 2



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.


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.

Outlook Add-In

Figure 1 – Outlook Add-In


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 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


    '  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()
            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


                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
        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)
            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
        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
            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
        End Try
    End Function

StripCharacters Function

    '''Strip Invalid Characters from Subjects
    Function StripCharacters(ByVal strSubs As String) As String
            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
        End Try
    End Function

AddFunnyToolbar Sub

    Private Sub AddFunnyToolbar()
            ' 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
            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

    End Sub

    Private Sub ThisAddIn_Shutdown(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Shutdown

            objAppObject = Nothing 'Remove Object References

        Catch ex As Exception
        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

More by Author

Get the Free Newsletter!

Subscribe to Developer Insider for top news, trends & analysis

Must Read