为outlook增加“邮件召回”功能

outlook 2007开始软件自带邮件召回功能。2003版本没有，可惜此版本盗版最厉害，用户很广，这次项目中用户分布很广，其中outlook2003版本用户数甚多，达到397人。

不可能让他们新装2007/2010等，因此使用outlook2003“工具”菜单中的VBA宏编辑器进行开发

邮件召回的前提：

1、必须是exchange邮件

2、收件人必须是outlook客户端，OWA不支持

3、收件人必须未读邮件

Private WithEvents vsoCommbandButton As CommandBarButton

Private WithEvents vsoCommbandRecallMessage As CommandBarButton

Dim item As Object

Private Sub Application_Startup()

Call addTotalButton

End Sub

'增加工具栏

Sub addTotalButton()

On Error Resume Next

Dim vsoCommandBar As CommandBar

'得到要添加的工具栏

Set vsoCommandBar = Outlook.ActiveExplorer.CommandBars("ExcelClub")

'如果工具栏为空，则增加

If (vsoCommandBar Is Nothing) Then

Set vsoCommandBar = Outlook.ActiveExplorer.CommandBars.add("ExcelClub", msoBarTop)

'在工具栏上增加一个按钮

Set vsoCommbandRecallMessage = vsoCommandBar.Controls.add(1)

vsoCommbandRecallMessage.Caption = "RecallMail"

vsoCommbandRecallMessage.FaceId = 72

vsoCommbandRecallMessage.Style = msoButtonIconAndCaption

 '显示增加的工具栏

vsoCommandBar.Visible = True

Else

Set vsoCommbandRecallMessage = vsoCommandBar.Controls(1)

End If

End Sub

'增加的按钮（RecallMail）的执行

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

'出现错误时下一句代码继续运行

On Error Resume Next

Dim objNS As Outlook.NameSpace

Dim myItem As Outlook.mailItem, objSendFolder As Outlook.MAPIFolder

Dim objItems    As Outlook.Items

Dim tmpItem As Object

Set objNS = Application.GetNamespace("MAPI")

Set objSendFolder = objNS.GetDefaultFolder(olFolderSentMail)

Set objItems = objSendFolder.Items

objItems.Sort "[SentOn]", True

Set tmpItem = objItems.GetFirst

Do While TypeName(tmpItem) <> "Nothing"

        If TypeName(tmpItem) = "MailItem" Then

        Set myItem = tmpItem

        Exit Do

        End If

    Set tmpItem = objItems.GetNext

Loop

Set item = myItem

item.Display

Call ShowAttachmentDialog

myItem.Close olDiscard

End Sub

 Sub ShowAttachmentDialog()

    Dim objInsp

    Dim colCB

    Dim objCBB

    On Error Resume Next

    Set objInsp = item.GetInspector

    Set colCB = objInsp.CommandBars

    Set objCBB = colCB.FindControl(, 2511)

    If Not objCBB Is Nothing Then

        SendKeys "{ENTER}", wait

        objCBB.Execute

    End If

    Set objCBB = Nothing

    Set colCB = Nothing

    Set objInsp = Nothing

End Sub