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

Question

我有一个至少有15个人使用和定期更新的工作簿，其中包含客户信息以及H3：H1500列中的电子邮件。使用Worksheet_FollowHyperlink事件，我们可以通过预先编写的Outlook帐户发送电子邮件，这些帐户取决于请求订单的星期几（MF，周六和周日），并且代码可以很好地生成消息。 我的主要问题是跟踪对客户的响应。 每当选择H列中的超链接时，我都尝试有一个记录日期（NOW函数）和Environ（“用户名”）的子项，但是由于我将电子邮件子项设置为.Display（因此人们可以在最后一分钟进行调整，如果需要的话，它仅记录谁选择了超链接（显然，从不实际发送消息时，偶然发生的很多事情）。我在整个论坛中发现了几个线程，其他线程引用了创建Class模块的方法，并实现了一个线程，以查看它是否可以在我的代码中使用，但是通过添加它，整个电子邮件子程序都变得无用了，所以我恢复为旧的形式。由于我对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时通过VBA来发送邮件，而不是FollowHyperlink事件
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

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

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 Application事件处理程序类的原始解决方案中对此进行了修订，该解决方案受到以下事实的限制：它将捕获任何 item_send事件，这是有问题的，因为多任务用户将发送误报。修订后的解决方案对MailItem在运行时创建的对象使用事件处理程序，应避免这种陷阱。

可能还有其他限制

例如，此方法实际上并不能处理“多个”电子邮件，因此，如果用户单击一个链接，然后单击另一个链接，则仅存在一个电子邮件，并且可以对其进行跟踪。如果您需要处理多封电子邮件，请使用Collection此类的公共对象，我对此问题做了类似处理。

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