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

我有一个工作簿，至less有15个人在H3：H1500列中定期使用和更新包含客户信息的电子邮件。 通过使用Worksheet_FollowHyperlink事件，我们可以通过预先写好的Outlook帐户发送电子邮件，并且依赖于一周中哪一天需要订购（MF，星期六和星期天），而且代码可以很好地生成消息。 我的主要问题是跟踪对客户的回应。 我试过有一个loggingdate（NOW函数）和Environ（“用户名”）的列，只要列H中的超链接被选中，但是因为我把电子邮件子集设置为.Display（所以人们可以做任何最后一分钟的调整如果需要的话），它只logging谁select了超链接（当消息从未实际发送时，显然发生了很多意外事件）。 我在这个论坛上发现了几个线程，其他人也参考创build了一个Class模块，并且实现了一个用于查看它是否可以在我的代码中工作的线程，但是通过添加它，整个电子邮件子文件变得无用，所以我恢复了原来的状态旧的forms。 由于我在VBA方面并不是非常有经验（我得到了很多帮助和试错），所以我意识到我的一些代码select可能看起来很愚蠢，如果有更好的方法可以做到这一点，它 – 我只知道，这张纸大多是现在的作品，我希望它可以改善，如果可能的话。

我目前的电子邮件是：

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的线程中处理事件，真的很有趣Q，我不知道这是否可能。 我想这会让你开始。

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

问题：超链接正在打开另一个应用程序（Outlook），通过它您没有完全控制。 至less从VBA方面来说，你不能控制Outlook事件。

我认为可能有一个更简单的方法来解决一个解决scheme，但这是一个死胡同，你暗示了类对象，所以我想我有一个想法可能工作…从来没有这样做过，所以这是一个工作进行中。

为了解决这个问题，我解决了一个办法：

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

这里是代码/说明：

创build一个名为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应用程序事件处理程序类的解决scheme，由于它会捕获任何 item_send事件，所以这是有问题的，因为多任务用户会发送误报。 修订后的解决scheme使用运行时创build的MailItem对象的事件处理程序，并应避免该陷阱。

可能有其他限制

例如，这种方法并没有真正处理“多个”电子邮件，所以如果用户点击一个链接，然后另一个链接，将只有一个电子邮件存在，可以跟踪。 如果你需要处理多个电子邮件，使用这个类对象的公共Collection ，我为这个类似的问题做了。

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