如何从 Excel 应用程序中捕获 Outlook 事件

Question

我有一本至少有 15 人使用并定期更新的工作簿，其中包含客户信息以及 H3:H1500 列中的电子邮件。使用 Worksheet_FollowHyperlink 事件，我们可以通过我们的 Outlook 帐户发送电子邮件，这些帐户是预先编写的，并且取决于请求订单的一周中的哪一天（周一至周五、周六和周日），并且代码可以很好地生成消息。 我的主要问题是跟踪对客户端的响应。 em>我尝试使用录制日期（现在的函数）和环境（“用户名”），只要选择H列中的超链接，而且就像我拥有的​​那样电子邮件子设置为 .Display（因此人们可以在需要时进行任何最后一分钟的调整）它只记录谁选择了超链接（当消息从未实际发送时，显然发生了很多意外）。我在整个论坛中发现了几个线程以及其他引用创建类模块的线程，我实现了一个用于查看它是否可以在我的代码中工作的线程，但是通过添加它，整个电子邮件子变得无用，所以我恢复到旧形式。由于我在 VBA 方面不是很有经验（由于帮助和反复试验，我已经走到了这一步），我意识到我的一些代码选择可能看起来很愚蠢，如果有更好的方法来做到这一点，我愿意它 - 我只知道，这张表目前大部分有效，如果可能的话，我希望可以改进它。

我当前的电子邮件子是：

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim Body1, Body2, Body3 As String
Dim olApp As Outlook.Application
Dim OlMail As Outlook.MailItem

On Error Resume Next
Application.EnableEvents = False

Set olApp = GetObject(,"Outlook.Application")

Do While olApp.Inspectors.Count = 0
DoEvents

Loop

Set olMail = olApp.Inspectors.Item(1).CurrentItem

With olMail

Body1 = "This is my weekday text"
Body2 = "This is my Saturday text"
Body3 = "This is my Sunday text"

.Subject = "Subject"
.Attachemnts.Add "C:\Path"
.CC = Target.Range.Offset(0,4).Text
.BCC = ""

If Target.Range.Offset(0,5).Text = "No" Then
.Body1
If Target.Range.Offset(0,5).Text = "Yes" Then
.Body2
If Target.Range.Offset(0,5).Text = "Sunday" Then
.Body3

.Display
End With

forward:
Application.EnableEvents = True
Exit Sub
halt:
MsgBox Err.Description
Resume forward
End Sub

[上面的代码在 Excel VBE 中，下面的代码在 Outlook VBE 中，我应该在开始之前包含它 - 它现在对我来说工作正常，所以我不确定它为什么没有编译。 ..]

Function GetCurrentItem() As Object
Dim objApp As Application

Set objApp = CreateObject("Outlook.Application")
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function

感谢任何帮助！

Answer 1

您正在尝试通过 Excel 线程处理 Outlook 中的事件，这真的很有趣，我不知道这是否可能。我想这会让你开始。

我希望能够跟踪访问电子邮件超链接并实际发送它的用户和日期。

问题：超链接正在打开另一个应用程序 (Outlook)，您无法完全控制该应用程序。至少在 VBA 方面，您无法控制 Outlook 事件。

我认为可能有一种更简单的方法来破解解决方案，但这是一个死胡同，你暗示了类对象，所以我想我有一个可能可行的想法......虽然以前从未这样做过，所以这是一项正在进行的工作。

为了解决这个问题，我选择了一种方法：

1. 终止超链接，使其不会自动启动 Outlook
2. 使用SelectionChange 事件而不是FollowHyperlink 事件通过VBA 发送邮件
3. 为 Outlook MailItem 创建一个自定义事件处理程序类对象，该对象将捕获 _Send 事件，然后您可以使用它来记录发送的详细信息。

以下是代码/说明：

创建一个名为cMailItem 的类对象并将这段代码放入其中：

Option Explicit
'MailItem event handler class
Public WithEvents m As Outlook.MailItem

Public Sub Class_initialize()

    Set m = olApp.CreateItem(0)

End Sub

Private Sub m_Send(Cancel As Boolean)

        Debug.Print "Item was sent by " & Environ("Username") & " at " & Now()
        Call ReleaseTrap

End Sub

在 STANDARD 代码模块中（我称之为HelperFunctions，但名称无关紧要）放入此代码，它将为我们的cMailItem 事件处理程序类设置一个标志，并且包含返回 Outlook 应用程序实例的函数。

Option Explicit
'#################
'NOTE: The TrapEvents should be called when the Forms are initialized
'NOTE: The ReleaseTrap should be called when the Forms are closed
Public olApp As Outlook.Application
Public cMail As New cMailItem
Public TrapFlag As Boolean

Sub TrapEvents()
If Not TrapFlag Then
   Set olApp = GetApplication("Outlook.Application")
   TrapFlag = True
End If
End Sub

Sub ReleaseTrap()
If TrapFlag = True Then
   Set olApp = Nothing
   Set cMail = Nothing
   TrapFlag = False
End If
End Sub

Function GetApplication(Class As String) As Object
'Handles creating/getting the instance of an application class
Dim ret As Object

On Error Resume Next

Set ret = GetObject(, Class)
If Err.Number <> 0 Then
    Set ret = CreateObject(Class)
End If

Set GetApplication = ret

On Error GoTo 0

End Function

现在，部分问题在于超链接跟随优先于其他事件的方式。为了避免这种情况，我使用一些代码来“杀死”超链接。它们只会“链接”到它们所在的单元格，但它们仍将包含电子邮件地址的文本。

我没有使用FollowHyperlink 事件，而是使用SelectionChange 事件来调用另一个发送邮件的过程。

在您的 WORKSHEET 模块中，放置以下事件处理程序和 SendMail 过程：

Option Explicit

Private Sub Worksheet_Activate()
'Converts Mailto hyperlinks so that they do NOT
' automatically open Outlook MailItem

    Dim h As Hyperlink

    For Each h In ActiveSheet.Hyperlinks
        If h.Address Like "mailto:*" Then
            h.ScreenTip = h.Address
            h.Address = ""
            h.SubAddress = h.Range.Address
        End If

    Next

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Disable Excel events
Application.EnableEvents = False

    If Target.Cells.Count <> 1 Then GoTo EarlyExit
    If Target.Hyperlinks.Count <> 1 Then GoTo EarlyExit

    'Send mail to the specified recipient/etc.
    Call SendMail(Target)

EarlyExit:
'Re-enable events:
Application.EnableEvents = True

End Sub
Private Sub SendMail(Target As Range)

Dim Body1$, Body2$, Body3$
Dim OlMail As Outlook.MailItem
Const OLMAILITEM As Long = 0

'Set our Outlook event trap
Call TrapEvents

'CREATE the mailitem
Set OlMail = cMail.m 

With OlMail

    Body1 = "This is my weekday text"
    Body2 = "This is my Saturday text"
    Body3 = "This is my Sunday text"

    .To = Target.Text
    .Subject = "Subject"
    '.Attachemnts.Add "C:\Path"
    .CC = Target.Offset(0, 4).Text
    .BCC = ""

    .Display
End With


End Sub

关于修订答案的说明

我对使用 Outlook 应用程序事件处理程序类的原始解决方案进行了修改，该解决方案受限于它会捕获 ANY item_send 事件这一事实，这是有问题的，因为多任务用户会发送误报。修改后的解决方案使用在运行时创建的MailItem 对象的事件处理程序，并且应该避免这个陷阱。

可能存在其他限制

例如，这种方法并不能真正处理“多封”电子邮件，因此如果用户点击一个链接，然后点击另一个，则只有一封电子邮件存在并且可以被跟踪。如果您需要处理多封电子邮件，请使用此类对象的公共Collection，我为this similar question 做过。

正如我所说，这是我第一次尝试在两个应用程序之间使用WithEvents 处理程序。我在单应用插件等中使用过主题，但从未以这种方式绑定两个应用程序，所以这对我来说是未知领域。