Question

我有一个工作簿，至少有15个人定期使用和更新，其中包含客户信息和电子邮件列H3：H1500。使用Worksheet_FollowHyperlink事件，我们可以通过我们预先编写的Outlook帐户发送电子邮件，具体取决于请求订单的星期几（M-F，周六和周日），并且代码可以正常生成消息。 我的主要问题是跟踪对客户的响应。每当选择H列中的超链接时，我尝试使用记录日期（NOW功能）和Environ（“用户名”）的子，但是我有电子邮件子集设置为.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

你正在尝试使用Outlook中的事件，从一个Excel线程，真的很有趣的Q，我不知道它是否可能。我想这会让你开始。

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

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

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

为了解决这个问题，我采取了一种方法：

终止超链接，以便它们不会自动启动Outlook
使用SelectionChange事件通过VBA发送邮件而不是FollowHyperlink事件
为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事件设置一个标志Handler类，还包含返回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应用程序事件处理程序类的原始解决方案中对此进行了修订，该解决方案由于它会捕获 ANY item_send事件而受到限制，这是有问题的，因为多任务用户会发送误报。修订后的解决方案使用了在运行时创建的MailItem对象的事件处理程序，并且应该避免这个陷阱。

可能存在其他限制

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

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

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

1 个答案: