学步园

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