Code Samples

Home  Products  Contact Us  About Us  Books

 

Sample Outlook 2007 COM Addin projects and project templates are available for download from this Web site by courtesy of Wrox Press. These projects and templates were developed for Professional Outlook 2007 Programming. The projects and templates are also available for download at www.wrox.com.

These code samples are are provided as is, as a courtesy, and no technical support is provided for them. These code samples are among the ones requested most often in the Outlook newsgroups.

More code samples for Outlook and CDO can be found at http://www.outlookcode.com and http://www.cdolive.com/cdo5.htm

A list of CDO Property Tags, many of them undocumented anywhere else, can be found at http://www.cdolive.com/cdo10.htm

I highly recommend www.slipstick.com as a reference resource for all things Outlook and Exchange related, and www.outlookcode.com as a resource for Outlook and Exchange related coding. For information about CDO, I recommend www.cdolive.com 

 

Strip All Attachments From Selected Email Items

Insert A Date/Time Stamp In The Current Email Item

Open A Custom Form Template

Open A Custom Form In A Specific Folder

Get The Sender's Email Address

Sending And Receiving Email Items

Capture The Internet Headers From The Current Message

Create A Toolbar Button With A Hyperlink To A Web Site

Add A Disclaimer To An Email Item

Extract The Members Of An Outlook Distribution List To A Word Document

Sort an Outlook Address Book

Change The FileAs Setting For A Contacts Folder

Inspector Wrapper

Retrieving the Exchange Version

 

Top

Strip all attachments from selected email items

Public Sub StripAttachments()
    Dim objOL As Outlook.Application
    Dim objMsg As Object
    Dim objAttachments As Outlook.Attachments
    Dim objSelection As Outlook.Selection
    Dim i As Long
    Dim lngCount As Long
    Dim strFile As String
    Dim strFolder As String

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = CreateObject("Outlook.Application")
    ' Get the collection of selected objects.
    Set objSelection = objOL.ActiveExplorer.Selection

    ' Get the Temp folder.
    strFolder = GetTempDir()
    If strFolder = "" Then
        MsgBox "Could not get Temp folder", vbOKOnly
        GoTo ExitSub
    End If

    ' Check each selected item for attachments.
    ' If attachments exist, save them to the Temp
    ' folder and strip them from the item.
    For Each objMsg In objSelection
        ' This code only strips attachments from mail items.
        If objMsg.Class = olMail Then
            ' Get the Attachments collection of the item.
            Set objAttachments = objMsg.Attachments
            lngCount = objAttachments.Count
            If lngCount > 0 Then
                ' We need to use a count down loop for
                ' removing items from a collection. Otherwise,
                ' the loop counter gets confused and only every
                ' other item is removed.
                For i = lngCount To 1 Step -1
                    ' Save attachment before deleting from item.
                    ' Get the file name.
                    strFile = objAttachments.Item(i).FileName
                    ' Combine with the path to the Temp folder.
                    strFile = strFolder & strFile
                    ' Save the attachment as a file.
                    objAttachments.Item(i).SaveAsFile strFile
                    ' Delete the attachment.
                    objAttachments.Item(i).Delete
                Next i
            End If
            objMsg.Save
        End If
    Next

ExitSub:
    Set objAttachments = Nothing
    Set objMsg = Nothing
    Set objSelection = Nothing
    Set objOL = Nothing
End Sub

Private Function GetTempDir() As String
    Const TemporaryFolder = 2

    'Requires a project reference to "Scrrun.dll" (Windows Scripting)
    Dim fso As Scripting.FileSystemObject
    Dim tFolder As Scripting.Folder

    On Error Resume Next

    ' Instantiate a WSH (Windows Scripting Host)
    ' FileSystemObject.
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' Get the Temp folder.
    Set tFolder = fso.GetSpecialFolder(TemporaryFolder)

    If Err Then
        GetTempDir = ""
    Else
        GetTempDir = LCase(tFolder.Path)
        ' Add "\" to the rightmost part of the path to
        ' the Temp folder if necessary.
        If Right$(GetTempDir, 1) <> "\" Then
            GetTempDir = GetTempDir & "\"
        End If
    End If

    Set fso = Nothing
    Set tFolder = Nothing
End Function

Top

Insert a Date/Time stamp in the current email item

Public Sub TimeStamp()
    Dim objOutlook As Outlook.Application
    Dim objInspector As Outlook.Inspector
    Dim objItem As Object 'Allow any Outlook item type.

    Dim strDateTime As String

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")

    ' The ActiveInspector is the currently open item.
    Set objInspector = objOutlook.ActiveInspector

    ' Check and see if anything is open.
    If Not objInspector Is Nothing Then
        ' Get the current item.
        Set objItem = objInspector.CurrentItem

        ' Get the current date and time.
        strDateTime = Now()

        objItem.Body = strDateTime & objItem.Body

        ' To add the date and time stamp to the end of the item,
        ' comment the preceding code line and uncomment the
        ' following code line.
        objItem.Body = objItem.Body & strDateTime

    Else
        ' Show error message with only the OK button.
        MsgBox "No item is open", vbOKOnly
    End If

    ' Set all objects equal to Nothing to destroy them and
    ' release the memory and resources they take.
    Set objOutlook = Nothing
    Set objInspector = Nothing
    Set objItem = Nothing
End Sub

Top

Open a custom form template

Public Sub CustomContact()
    Dim objOutlook As Outlook.Application
    Dim objForm As Outlook.ContactItem

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")

    Set objForm = objOutlook.CreateItemFromTemplate("C:\My " _
        & "Documents\CustomContact.oft")
    objForm.Display

    Set objForm = Nothing
    Set objOutlook = Nothing
End Sub

Top

Open a custom form in a specific folder

Public Sub OpenForm()
    Dim objOutlook As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objFolder As Outlook.MAPIFolder
    Dim objForm As Outlook.ContactItem
    Dim objItems As Outlook.Items

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")

    Set objNS = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNS.GetDefaultFolder(olFolderContacts)
    Set objItems = objFolder.Items
    Set objForm = objItems.Add("IPM.Contact.CustomContact")
    objForm.Display

    Set objNS = Nothing
    Set objFolder = Nothing
    Set objItems = Nothing
    Set objForm = Nothing
    Set objOutlook = Nothing
End Sub

Top

Get the sender's email address

Public Sub FromAddress()
    'Requires a project reference to CDO 1.21 (CDO.DLL)
    Dim objOutlook As Outlook.Application
    Dim objItem As Outlook.MailItem
    Dim objSession As MAPI.Session
    Dim objMsg As MAPI.Message
    Dim objSender As MAPI.AddressEntry
    Dim strAddress As String
    Dim strName As String
    Dim strEntryID As String

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")

    'The ActiveInspector window is the currently active window
    'That is displaying individual Outlook items. Outlook folders
    'are displayed in Explorer windows.
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    'SenderName is the friendly name
    strName = objItem.SenderName
    'We need the EntryID of the item to locate it with CDO
    strEntryID = objItem.EntryID

    'Establish a CDO (MAPI) Session object and logon to it
    Set objSession = CreateObject("MAPI.Session")
    objSession.Logon "",  "", False, False

    'Locate the current message with the EntryID using CDO
    Set objMsg = objSession.GetMessage(strEntryID)
    'Get the sender
    Set objSender = objMsg.Sender
    'Get the actual email address
    strAddress = objSender.Address
    'Display the information in a MsgBox
    MsgBox "Name: " & strName & vbCrLf & "Email Address: " _
        & strAddress

    'Close MAPI (CDO) Session
    objSession.Logoff

    Set objItem = Nothing
    Set objSession = Nothing
    Set objMsg = Nothing
    Set objSender = Nothing
    Set objOutlook = Nothing
End Sub

Top

Sending and receiving email items

Send and receive in Outlook 2000 Corporate or Workgroup mode or Outlook 2002. This code will cause an error in Outlook 2000 Internet Only mode. It will also cause a security prompt in Outlook 2000 SP2 or Outlook 2002.

Public Sub SendReceiveNowCorpMode()
    'Only works in Corporate/Workgroup mode
    'Requires a project reference to CDO 1.21 (CDO.DLL)
    Dim objCDO As MAPI.Session

    On Error Resume Next

    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False
    objCDO.DeliverNow

    objCDO.Logoff
    Set objCDO = Nothing
End Sub

Code to send and receive in Outlook 2000 or Outlook 2002. It will cause a security prompt in Outlook 2000 SP2 or Outlook 2002.

Public Sub SendReceiveNow()
    Dim objOutlook As Outlook.Application
    Dim objCtl As Office.CommandBarControl
    Dim objPop As Office.CommandBarPopup
    Dim objCB As Office.CommandBar
    Dim objItem As Object

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")

    'First find and send the current item to the Outbox
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    objItem.Send

    'Then use the Send/Receive on All Accounts action in the Tools
    'menu to send the item from the Outbox, and receive new items
    Set objCB = objOutlook.ActiveExplorer.CommandBars("Menu Bar")
    Set objPop = objCB.Controls("Tools")
    Set objPop = objPop.Controls("Send/Receive")
    Set objCtl = objPop.Controls("All Accounts")
    objCtl.Execute

    Set objCtl = Nothing
    Set objPop = Nothing
    Set objCB = Nothing
    Set objItem = Nothing
    Set objOutlook = Nothing
End Sub

Code to only send email in Outlook 2000 or Outlook 2002. It will cause a security prompt in Outlook 2000 SP2 or Outlook 2002.

Public Sub SendNow()
    Dim objOutlook As Outlook.Application
    Dim objCtl As Office.CommandBarControl
    Dim objPop As Office.CommandBarPopup
    Dim objCB As Office.CommandBar
    Dim objItem As Object

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")

    'First find and send the current item to the Outbox
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    objItem.Send

    'Then use the Send action in the Tools menu
    'to send the item from the Outbox
    Set objCB = objOutlook.ActiveExplorer.CommandBars("Menu Bar")
    Set objPop = objCB.Controls("Tools")
    Set objCtl = objPop.Controls("Send")
    objCtl.Execute

    Set objCtl = Nothing
    Set objPop = Nothing
    Set objCB = Nothing
    Set objItem = Nothing
    Set objOutlook = Nothing
End Sub

Top

Capture the Internet headers from the current message

The Internet headers are only present in emails received from POP3 emails. They are not present in emails sent over Microsoft Exchange server. This function returns the Internet headers as a string value.

Public Function InternetHeaders() As String
    'Requires a project reference to CDO 1.21 (CDO.DLL)
    Dim objOutlook As Outlook.Application
    Dim objItem As Outlook.MailItem
    Dim objCDO As MAPI.Session
    Dim objMessage As MAPI.Message
    Dim objFields As MAPI.Fields
    Dim strID As String

    Const CdoPR_TRANSPORT_MESSAGE_HEADERS = &H7D001E

    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")

    'Find the current email item and get its EntryID
    Set objItem = objOutlook.ActiveInspector.CurrentItem
    strID = objItem.EntryID

    'Then set up a CDO Session using a piggy-back login
    Set objCDO = CreateObject("MAPI.Session")
    objCDO.Logon "", "", False, False

    'Now get the item as a CDO Message
    Set objMessage =  objCDO.GetMessage(strID)

    'Now get the headers from the message
    Set objFields = objMessage.Fields
    InternetHeaders = objFields.Item(CdoPR_TRANSPORT_MESSAGE_HEADERS).Value
    'Now that the headers are captured in a string you can do whatever you want with them

    objCDO.Logoff

    Set objFields = Nothing
    Set objMessage = Nothing
    Set objCDO = Nothing
    Set objItem = Nothing
    Set objOutlook = Nothing
End Function

Top

Create a toolbar button with a hyperlink to a Web site

This code does not check to see if the hyperlink button already exists. It adds the button to the Standard toolbar.

Public Sub AddHyperlink()
    Dim objButton As Office.CommandBarButton
    Dim objBar As Office.CommandBar

    Set objBar = ActiveExplorer.CommandBars("Standard")
    Set objButton = objBar.Controls.Add(msoControlButton)

    With objButton
        .Caption = "Slovaktech Web &Site"
        .Tag = "SlovaktechWebSite"
        .HyperlinkType = msoCommandBarButtonHyperlinkOpen
        .ToolTipText = "http://www.slovaktech.com"
    End With

Set objButton = Nothing
Set objBar = Nothing
End Sub

Top

Add a disclaimer to an email item

Public Sub Disclaimer()
    Dim objOutlook As Outlook.Application
    Dim objInspector As Outlook.Inspector
    Dim objMail As Outlook.MailItem
    Dim strDisclaimer As String

    On Error GoTo ErrorHandler

    'Create the disclaimer string.
    strDisclaimer = "The information contained in this message " _
    & "constitutes privileged and confidential information " _
    & "and is intended only for the use of and review by " _
    & "the recipient designated above."
    'Add a blank line between the email text and the disclaimer.
    strDisclaimer = vbCrLf & strDisclaimer

    Set objOutlook = CreateObject("Outlook.Application")

    'The ActiveInspector is the currently open item.
    Set objInspector = objOutlook.ActiveInspector

    'Check and see if anything is open.
    If Not objInspector Is Nothing Then
        'See if the current item is an e-mail item.
        If objInspector.CurrentItem.Class = olMail Then
            'Get the current mail item.
            Set objMail = objInspector.CurrentItem
            'Add the disclaimer to the end of the e-mail.
            objMail.Body = objMail.Body & strDisclaimer
        Else
            'Show error message with only the OK button.
            MsgBox "This is not an e-mail item"
        End If
    Else
        'Show error message with only the OK button.
        MsgBox "No item is open"
    End If

MacroExit:
    'Set all objects equal to Nothing to destroy them and
    'release the memory and resources they take.
    Set objOutlook = Nothing
    Set objInspector = Nothing
    Set objMail = Nothing

    Exit Sub

ErrorHandler:
    'Display the description and number of the error.
    MsgBox "Error: " & Err.Description & vbCrLf & "Error # " _
        & Err.Number

    'Clear the error.
    Err.Clear

    'Exit the macro.
    GoTo MacroExit
End Sub

Top

Extract the members of an Outlook Distribution List to a Word document

Public Sub DLToWord()
    'This macro requires project references to the Outlook
    'and Word object models.
    Dim objOutlook As Outlook.Application
    Dim objExplorer As Outlook.Explorer
    Dim objSelection As Outlook.Selection
    Dim objDL As Outlook.DistListItem
    Dim objRecipient As Outlook.Recipient

    Dim objWord As Word.Application
    Dim objDoc As Word.Document
    Dim objTable As Word.Table
    Dim objRange As Word.Range

    Dim lngCount As Long
    Dim lngIndex As Long
    Dim strName As String
    Dim strAddress As String
    Dim strListName As String

    On Error GoTo ErrorHandler

    Set objOutlook = CreateObject("Outlook.Application")

    'Get the currently active folder window.
    Set objExplorer = objOutlook.ActiveExplorer

    'Get the selected item(s) in that folder.
    Set objSelection = objExplorer.Selection

    'Look for 1 distribution list item to be selected.
    If objSelection.Count = 1 And _
        objSelection.Item(1).Class = olDistributionList Then

        'Get the selection.
        Set objDL = objSelection.Item(1)

        'Get the name of the distribution list.
        strListName = objDL.DLName

        'Go to next line if there is an error.
        On Error Resume Next

        'See if Word is already open.
        Set objWord = GetObject(, "Word.Application")

        'If not, create a new Word application object.
        If objWord Is Nothing Then
            Set objWord = CreateObject("Word.Application")
        End If

        'Now back to the normal error handler.
        On Error GoTo ErrorHandler

        'Add a new document to Word and activate it.
        Set objDoc = objWord.Documents.Add
        objDoc.Activate

        'Set the active range to the document start.
        Set objRange = objDoc.Range(0, 0)

        'See how many items are in the distribution list.
        lngCount = objDL.MemberCount

        'Add a Word table, with 1 more row than list members,
        'use the first row for the list name. Table has 2 columns.
        Set objTable = objDoc.Tables.Add(objRange, lngCount + 1, 2)

        'Use With to make the code faster.
        With objTable
            'Insert the list name in the first row, first column.
            .Cell(1, 1).Range.InsertAfter strListName

            'Make the list name bold face.
            .Cell(1, 1).Range.Bold = True

            'Now loop through the members of the list.
            For lngIndex = 1 To lngCount
                'Get a list member
                Set objRecipient = objDL.GetMember(lngIndex)

                'Get the name of the list member.
                strName = objRecipient.Name

                'Get the e-mail address of the list member.
                strAddress = objRecipient.Address

                'Insert the name and e-mail address.
                .Cell(lngIndex + 1, 1).Range.InsertAfter strName
                .Cell(lngIndex + 1, 2).Range.InsertAfter strAddress
            Next lngIndex
            .Columns.AutoFit
        End With

        'Move the cursor to the end of the document.
        objWord.Selection.HomeKey Unit := wdStory, Extend := wdMove

        'Make the document visible.
        objWord.Visible = True
        objDoc.ActiveWindow.Visible = True
    Else
        MsgBox "Not a Distribution List or more than 1 item is selected"
    End If

MacroExit:
    Set objOutlook = Nothing
    Set objExplorer = Nothing
    Set objSelection = Nothing
    Set objDL = Nothing
    Set objRecipient = Nothing

    Set objWord = Nothing
    Set objDoc = Nothing
    Set objTable = Nothing
    Set objRange = Nothing

    Exit Sub

ErrorHandler:
    MsgBox "Error: " & Err.Description & vbCrLf & "Error # " _
        & Err.Number

    Err.Clear
    GoTo MacroExit
End Sub

Top

Sort an Outlook Address Book

Public Sub SortAddressBook()
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objContactFolder As Outlook.MAPIFolder
    Dim objContact As Outlook.ContactItem
    Dim objItems As Outlook.Items
    Dim obj As Object
    Dim strLastName As String
    Dim strFirstName As String
    Dim strCompany As String

    On Error Resume Next

    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objContactFolder = objNS.GetDefaultFolder(olFolderContacts)
    Set objItems = objContactFolder.Items

    For Each obj In objItems
        'Test for contact and not distribution list
        If obj.Class = olContact Then
            Set objContact = obj

            With objContact
                strFirstName = .FirstName
                strLastName = .LastName
                strCompany = .CompanyName
                'The sort is by the Subject field
                .Subject = strLastName & ", " & strFirstName

                'To change the sort to company name, followed by name
                'uncomment the following lines and comment the preceding line
                '.Subject = strCompany
                '.Subject = strCompany & ", " & strLastName & ", " & strFirstName

                .Save
            End With
        End If

        Err.Clear
    Next

    Set objOL = Nothing
    Set objNS = Nothing
    Set obj = Nothing
    Set objContactFolder = Nothing
    Set objContact = Nothing
End Sub

Top

Change the FileAs setting for a Contacts folder

Public Sub ChangeFileAs()
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objContact As Outlook.ContactItem
    Dim objItems As Outlook.Items
    Dim objContactsFolder As Outlook.MAPIFolder
    Dim obj As Object
    Dim strFirstName As String
    Dim strLastName As String
    Dim strFileAs As String

    On Error Resume Next

    Set objOL = CreateObject("Outlook.Application")
    Set objNS = objOL.GetNamespace("MAPI")
    Set objContactsFolder = objNS.GetDefaultFolder(olFolderContacts)
    Set objItems = objContactsFolder.Items

    For Each obj In objItems
        'Test for contact and not distribution list
        If obj.Class = olContact Then
            Set objContact = obj

            With objContact
                strFirstName = .FirstName
                strLastName = .LastName
                strFileAs = strFirstName & " " & strLastName
                .FileAs = strFileAs

                .Save
            End With
        End If

        Err.Clear
    Next

    Set objOL = Nothing
    Set objNS = Nothing
    Set obj = Nothing
    Set objContact = Nothing
    Set objItems = Nothing
    Set objContactsFolder = Nothing
End Sub

Top

Inspector Wrapper

'************************************************************
' This code is in the class module where the init code is
' placed and where the NewInspector event is handled. The
' class module should declare an Inspectors collection using
' the WithEvents statement and then set up a NewInspector
' event handler.
'************************************************************

Private WithEvents colInsp As Outlook.Inspectors
Private WithEvents objInsp As Outlook.Inspector

Private Sub colInsp_NewInspector(ByVal Inspector As Inspector)
    Dim objItem As Object
    Dim strID As String

    On Error Resume Next

    Set objInsp = Inspector
    Set objItem = objInsp.CurrentItem
    'test for Outlook item type
    Select Case objItem.Class
    'use one Case clause for each type of Outlook item
    ' you want to handle events for. If you want to add
    ' buttons to an Inspector then always add the
    ' Inspector to the Inspector wrapper collection.
    Case olMail
        strID = AddInsp(Inspector)
    Case olContact
        strID = AddInsp(Inspector)
    End Select

    Set objItem = Nothing
End Sub

Private Sub objInsp_Close()
    On Error Resume Next

    'g_olApp is a global Outlook.Application object that is derived
    ' from the Application object passed to the COM addin in the
    ' On_Connection event.
    If g_olApp.Explorers.Count = 0 And g_olApp.Inspectors.Count <= 1 Then
        Set objInsp = Nothing
        'call the code to release all Outlook objects
        UnInitHandler
    End If
End Sub

'************************************************************
' This code is in a code module called basOutlInsp. The
' wrapper class for an Inspector is called clsInspWrap.
' The collection that holds the Inspector wrapper
' classes is called g_colInspWrap. It is declared in a
' code module as a global Collection object.
'************************************************************

Public g_colInspWrap As New Collection

Private intID As Integer
Private blnActivate As Boolean

Public Function AddInsp(Inspector As Outlook.Inspector) As String
    Dim objInspWrap As New clsInspWrap
    Dim objItem As Object
    Dim strID As String

    On Error Resume Next

    'set the Inspector in the class
    objInspWrap.Inspector = Inspector

    Set objItem = Inspector.CurrentItem
    'test which Outlook item type is here
    Select Case objItem.Class
    Case olMail
        'we are handling events for this item type,
        ' so add a new class to the collection and
        ' set up the item in the Inspector so events
        ' for the item can be handled.
        objInspWrap.MailItem = objItem
    Case olContact
        objInspWrap.ContactItem = objItem
        Case Else
     End Select

    objInspWrap.Key = intID
    strID = CStr(intID)
    'add the class to the collection with a
    ' unique Key value.
    g_colInspWrap.Add objInspWrap, strID

    'create buttons and menus for the Inspector
    objInspWrap.InitButton

    AddInsp = strID

    intID = intID + 1

    Set objInspWrap = Nothing
    Set objItem = Nothing
End Function

Public Sub KillInsp(intID As Integer, objInspWrap As clsInspWrap)
    Dim objInspWrap2 As clsInspWrap

    On Error Resume Next

    Set objInspWrap2 = g_colInspWrap.Item(CStr(intID))
    ' check to make sure we're removing the
    ' correct Inspector from the collection.
    If Not objInspWrap2 Is objInspWrap Then
        Err.Raise 1, Description:="Unexpected Error in KillInsp"
        GoTo ExitSub
    End If

    g_colInspWrap.Remove CStr(intID)

ExitSub:
    Set objInspWrap2 = Nothing
End Sub

'************************************************************
' This code is in the class module used as an Inspector
' wrapper. One instance of this class is added to a
' collection each time a new Inspector is opened and
' the instance is removed from the collection when the
' Inspector closed. The class is called clsInspWrap.
'************************************************************

Private WithEvents m_objInsp As Outlook.Inspector

Private WithEvents m_objMail As Outlook.MailItem

Private WithEvents m_objContact As Outlook.ContactItem

Private WithEvents cbbButton As Office.CommandBarButton

Private m_obj As Object

Private m_intID As Integer

Private mnuTag As String

Private m_blnMailInspector As Boolean

Private m_blnWord As Boolean

Private Sub cbbButton_Click(ByVal Ctrl As Office.CommandBarButton, _
    CancelDefault As Boolean)

    On Error Resume Next
    'code here to handle a click of the menu/toolbar button
    ' and perform whatever function you want.
End Sub

Private Sub Class_Initialize()
    On Error Resume Next

    Set m_objInsp = Nothing
    Set m_objMail = Nothing
    Set m_objContact = Nothing
    Set cbbButton = Nothing
    Set m_obj = Nothing

    m_blnWord = False
End Sub

Private Sub Class_Terminate()
    On Error Resume Next

    Set m_objInsp = Nothing
    Set m_objMail = Nothing
    Set m_objContact = Nothing
    Set cbbButton = Nothing
    Set m_obj = Nothing
End Sub

Public Function InitButton() As Boolean
    On Error Resume Next

    'if you want buttons only for
    ' certain item types you can test
    ' for that here using
    ' m_objInsp.CurrentItem.Class.
    Call CreateButtons(m_objInsp)

    'you can now enable/disable buttons depending
    ' on what type if item is opened if you want.

End Function

Public Property Let MailItem(objMail As Outlook.MailItem)
    On Error Resume Next

    Set m_objMail = objMail
    m_strMailID = objMail.EntryID
    m_blnMailInspector = True
End Property

Public Property Let ContactItem(objContact As Outlook.ContactItem)
    On Error Resume Next

    Set m_objContact = objContact
    m_strContactID = objContact.Importance
    m_blnMailInspector = False
End Property

Public Property Let Inspector(objInspector As Outlook.Inspector)
    On Error Resume Next

    Set m_objInsp = objInspector
End Property

Public Property Get Inspector() As Outlook.Inspector
    On Error Resume Next

    Set Inspector = m_objInsp
End Property

Public Property Let Key(lngID As Long)
    On Error Resume Next

    m_intID = lngID
End Property

Public Property Get Key() As Long
    On Error Resume Next

    Key = m_intID
End Property

Private Sub m_objContact_Close(Cancel As Boolean)
    On Error Resume Next

    'can handle various events for the contact item
    ' in the Inspector like Close and Open.
    On Error Resume Next

    If Cancel = False Then
        Call KillButtons
        basOutlInsp.KillInsp m_intID, Me
        Set m_objInsp = Nothing
    End If
End Sub

Private Sub m_objContact_Open(Cancel As Boolean)
    On Error Resume Next

    'can handle various events for the contact item
    ' in the Inspector like Close and Open.
End Sub

Private Sub m_objMail_Open(Cancel As Boolean)
    On Error Resume Next

    'can handle various events for the mail item
    ' in the Inspector like Close and Open.
End Sub

Private Sub m_objMail_Close(Cancel As Boolean)
    On Error Resume Next

    'can handle various events for the mail item
    ' in the Inspector like Close and Open.

    If Cancel = False Then
        Call KillButtons
        basOutlInsp.KillInsp m_intID, Me
        Set m_objInsp = Nothing
    End If
End Sub

'Destroy Inspector object in InspWrap
Private Sub m_objInsp_Close()
    On Error Resume Next

    Call KillButtons

    basOutlInsp.KillInsp m_intID, Me
    Set m_objInsp = Nothing
End Sub

Private Sub KillButtons()
    Dim oControl As Office.CommandBarControl

    On Error Resume Next

    Set oControl = m_obj.CommandBars.FindControl(Tag:=mnuTag)
    If Not oControl Is Nothing Then
        oControl.Delete
    End If

    Set oControl = Nothing
End Sub

Private Sub CreateButtons(objInspector As Outlook.Inspector)
    On Error Resume Next

    'Adding a new menu item and a button to the main menu for any Inspector
    ' must take a different approach if using Word as email editor.
    If (objInspector.IsWordMail = True) And _
        (objInspector.EditorType = olEditorWord) Then

        m_blnWord = True
        Set m_obj = Nothing
    Else
        m_blnWord = False
        Set m_obj = objInspector

        Call CreateMenus
    End If

    Err.Clear
End Sub

Private Sub CreateMenus()
    'add a menu to the main Outlook menu bar
    ' in the Inspector.
    Dim oControl As Office.CommandBarControl
    Dim strMenu As String
    Dim strTag As String
    Dim strToolTip As String
    Dim strCaption As String
    Dim strKey As String
    Dim blnMenuExists As Boolean

    On Error Resume Next

    strKey = CStr(m_intID)
    mnuTag = "This string is unique to this menu" & strKey

    strMenu = "Menu Bar"

    strToolTip = "The ToolTip for the menu"
    strCaption = "The caption for the menu"

    'check for the menu existing already and do not create
    ' it if does exist. The checking code would set a
    ' Boolean variable named blnMenuExists.

    If Not blnMenuExists Then
        Set oControl = 'create the new menu here
    Else
        Set oControl = m_obj.CommandBars.FindControl(Tag:=mnuTag)
    End If

    'now add a button to the new menu that was created
    If Not (oControl Is Nothing) Then
        Set m_oControlBar = oControl

        strTag = "This string is unique to this button" & strKey
        strToolTip = "The ToolTip for the button"
        strCaption = "The caption for the button"

        'create the button here
        Set cbbButton = 'new button
    End If

    Set oControl = Nothing
End Sub

Top

 Retrieving the Exchange Version

'Code to get Exchange version in online mode using Redemption.
'This code will return "0.0.0.0" for no Exchange, Outlook 2003
' cached mode or offline mode.
'
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal nLength As Long)

Type EXCH_VER
    Revision As Integer
    Build As Integer
    Minor As Integer
    Major As Integer
End Type

Const PR_REPLICA_VERSION = &H664B0014 'to get Exchange version

Function GetExchangeVersion() As String
    Dim ExchangeValue As Variant
    Dim tmpVer As EXCH_VER
    Dim rdmFolder As Redemption.rdoFolder
    Dim rdoSession As Redemption.rdoSession
    Dim oFolder As Outlook.MAPIFolder
    Dim vp As Long

    On Error Resume Next

    Set oFolder = Application.session.GetDefaultFolder(olFolderInbox)

    Set rdoSession = CreateObject("Redemption.rdoSession")

    'This uses Application, works in Outlook VBA.
    '
    'For other scenarios declare an Outlook.Application object
    ' and instantiate it.
    '
    'Use rdoSession.MAPIOBJECT and Application.session.MAPIOBJECT
    ' for Outlook 2002 or later. Use rdoSession.Logon for Outlook 2000.
    rdoSession.MAPIOBJECT = Application.session.MAPIOBJECT

    Set rdmFolder = rdoSession.GetFolderFromID(oFolder.EntryID, oFolder.StoreID)

    'See if the property for the Exchange version is there.
    'It won't be there if running in Outlook 2003 cached mode,
    ' offline mode or no Exchange is being used.
    If Not (IsEmpty(rdmFolder.Fields(PR_REPLICA_VERSION))) Then
        'Get the server version for the folder.
        ExchangeValue = rdmFolder.Fields(PR_REPLICA_VERSION)

        'get pointer to the PT_I8 value
        vp = VarPtr(ExchangeValue)

        'Only copy the memory contents to our structure when the
        'previous call succeeds.
        If Err = 0 Then
            CopyMemory tmpVer, ByVal (vp + 8), LenB(tmpVer)
        End If

        'Now set the return value. If we couldn't read the property,
        'this function returns "0.0.0.0".
        GetExchangeVersion = CStr(tmpVer.Major) & "." & CStr(tmpVer.Minor) & "." _
            & CStr(tmpVer.Build) & "." & CStr(tmpVer.Revision)
    Else
        GetExchangeVersion = "0.0.0.0"
    End If

    Set rdmFolder = Nothing
    Set rdoSession = Nothing
    Set oFolder = Nothing
End Function

Top

Send mail to webmaster@slovaktech.com with questions or comments about this Web site.
Copyright © 2002 - 2013 Slovak Technical Services

    Microsoft and the Office logo are trademarks or registered trademarks of Microsoft Corporation in the United States and/or other countries.

 

Last modified: March 19, 2013