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