EXCEL VBA，手动 Outlook 电子邮件发件人，类模块问题

Question

我仍在努力解决我在1st question 中描述的关于此主题的问题。对于短暂的刷新，它是一个包含电子邮件模板和附件列表的 excel 文件，我在每个列表单元中添加了打开发送单元模板的按钮进行一些更改，然后附加文件并将邮件显示到用户。用户可以根据需要修改邮件，然后发送或不发送邮件。我尝试了下面描述的几种方法。 不幸的是，我现在在类模块的问题上停滞不前，该问题简短地描述了here。我确实创建了一个类模块，例如“EmailWatcher”，甚至与here 描述的方法进行了小组合：

Option Explicit
Public WithEvents TheMail As Outlook.MailItem

Private Sub Class_Terminate()
Debug.Print "Terminate " & Now()  
End Sub

Public Sub INIT(x As Outlook.MailItem)
    Set TheMail = x
End Sub

Private Sub x_Send(Cancel As Boolean)
Debug.Print "Send " & Now()
ThisWorkbook.Worksheets(1).Range("J5") = Now()
'enter code here
End Sub

Private Sub Class_Initialize()
Debug.Print "Initialize " & Now()    
End Sub

以下表格的变化没有任何改变：

Option Explicit
Public WithEvents TheMail As Outlook.MailItem
    
    Private Sub Class_Terminate()
    Debug.Print "Terminate " & Now()  
    End Sub

    Public Sub INIT(x As Outlook.MailItem)
        Set TheMail = x
    End Sub
    
    Private Sub TheMail_Send(Cancel As Boolean)
    Debug.Print "Send " & Now()
    ThisWorkbook.Worksheets(1).Range("J5") = Now()
    'enter code here
    End Sub
    
    Private Sub Class_Initialize()
    Debug.Print "Initialize " & Now()    
    End Sub

模块代码如下：

Public Sub SendTo()
    Dim r, c As Integer
    Dim b As Object
    Set b = ActiveSheet.Buttons(Application.Caller)
    With b.TopLeftCell
        r = .Row
        c = .Column
    End With

    Dim filename As String, subject1 As String, path1, path2, wb As String
    Dim wbk As Workbook
    filename = ThisWorkbook.Worksheets(1).Cells(r, c + 5)
    path1 = Application.ThisWorkbook.Path & 
    ThisWorkbook.Worksheets(1).Range("F4")
    path2 = Application.ThisWorkbook.Path & 
    ThisWorkbook.Worksheets(1).Range("F6")
    wb = ThisWorkbook.Worksheets(1).Cells(r, c + 8)
    
    Dim outapp As Outlook.Application
    Dim oMail As Outlook.MailItem
    Set outapp = New Outlook.Application
    Set oMail = outapp.CreateItemFromTemplate(path1 & filename)

    subject1 = oMail.subject
    subject1 = Left(subject1, Len(subject1) - 10) & 
    Format(ThisWorkbook.Worksheets(1).Range("D7"), "DD/MM/YYYY")
    oMail.Display
    Dim CurrWatcher As EmailWatcher
    Set CurrWatcher = New EmailWatcher
    CurrWatcher.INIT oMail
    Set CurrWatcher.TheMail = oMail
    
    Set wbk = Workbooks.Open(filename:=path2 & wb)
    
    wbk.Worksheets(1).Range("I4") = 
    ThisWorkbook.Worksheets(1).Range("D7").Value
    wbk.Close True
    ThisWorkbook.Worksheets(1).Cells(r, c + 4) = subject1
    With oMail
        .subject = subject1
        .Attachments.Add (path2 & wb)
    End With
    With ThisWorkbook.Worksheets(1).Cells(r, c - 2)
        .Value = Now
        .Font.Color = vbWhite
    End With
    With ThisWorkbook.Worksheets(1).Cells(r, c - 1)
        .Value = "Was opened"
        .Select
    End With       
End Sub

最后，我创建了一个正在运行的类，并且我已经放置了一些控件来检查它，正如您从类模块代码中看到的那样。但问题是，它没有捕捉到 Send 事件。该类在子结束时终止。将电子邮件完全留给用户。问题是：错误在哪里？或者如何让类模块处于所谓的“等待模式”，或者任何其他建议？ 因此，我也考虑在“发件箱”中搜索邮件的方法，但发送事件的方法更受欢迎。

Answer 1

我回答了一个类似的问题here 并查看了该问题，我认为虽然您在正确的轨道上，但您的实施存在一些问题。试试这个：

照此做Class模块，去掉不必要的INIT过程，使用Class_Initialize过程创建Mailitem。

Option Explicit
Public WithEvents TheMail As Outlook.MailItem
    Private Sub Class_Terminate()
    Debug.Print "Terminate " & Now()
    End Sub
    Private Sub TheMail_Send(Cancel As Boolean)
    Debug.Print "Send " & Now()
    ThisWorkbook.Worksheets(1).Range("J5") = Now()
    'enter code here
    End Sub
    Private Sub Class_Initialize()
    Debug.Print "Initialize " & Now()
    'Have Outlook create a new mailitem and get a handle on this class events
    Set TheMail = olApp.CreateItem(0)
    End Sub

在普通模块中使用的示例，经过测试并确认这是有效的，并将处理 多个 电子邮件（我之前的回答没有完成）。

Option Explicit
Public olApp As Outlook.Application
Public WatchEmails As New Collection

Sub SendEmail()
If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
Dim thisMail As New EmailWatcher
WatchEmails.Add thisMail
thisMail.TheMail.Display
thisMail.TheMail.To = "someone@email.com"
thisMail.TheMail.Subject = "test"
thisMail.TheMail.Display
End Sub

它是如何工作的？首先，我们确保我们有一个 Outlook.Application 实例可以使用。这将在模块中限定为Public，因此它可用于其他过程和类。

然后，我们创建EmailWatcher 类的新实例，它引发Class_Initialize 事件。我们利用此事件和已处理的Outlook.Application 实例来创建和分配TheMail 对象事件处理程序。

我们将它们存储在Public 集合中，这样即使在SendMail 过程运行时间结束后它们仍然在作用域内。通过这种方式，您可以创建多封电子邮件，并且它们都会受到监控。

从那时起，thisMail.TheMail 代表MailItem，其事件在 Excel 下受到监视，并且在此对象上调用 .Send 方法（通过 VBA）或手动发送电子邮件应引发 TheMail_Send 事件过程。

Answer 2

Dim CurrWatcher As EmailWatcher

这一行必须是全局的，在任何子例程之外。

Answer 3

非常感谢大家的帮助和支持，终于搞定了。

由于我确实使用邮件模板，因此需要一些时间来弄清楚如何将它们添加到集合中。

这是我的解决方案。 类模块：

Option Explicit
Public WithEvents themail As Outlook.MailItem

Private Sub Class_Terminate()
Debug.Print "Terminate " & Now()
End Sub

Private Sub themail_Send(Cancel As Boolean)
Debug.Print "Send " & Now()
Call overwrite(r, c)
'enter code here
End Sub

Private Sub Class_Initialize()
Debug.Print "Initialize " & Now()
'Have Outlook create a new mailitem and get a handle on this class events
Set themail = OutApp.CreateItem(0)
Set themail = oMail
End Sub

模块：

Public Sub SendTo1()

Dim r, c As Integer
Dim b As Object
Set b = ActiveSheet.Buttons(Application.Caller)
With b.TopLeftCell
   r = .Row
   c = .Column
End With

Dim filename As String, subject1 As String, path1, path2, wb As String
Dim wbk As Workbook
filename = ThisWorkbook.Worksheets(1).Cells(r, c + 5)
path1 = Application.ThisWorkbook.Path & 
ThisWorkbook.Worksheets(1).Range("F4")
path2 = Application.ThisWorkbook.Path & 
ThisWorkbook.Worksheets(1).Range("F6")
wb = ThisWorkbook.Worksheets(1).Cells(r, c + 8)

Dim OutApp As Outlook.Application
Dim oMail As Outlook.MailItem
Set OutApp = New Outlook.Application
Set oMail = OutApp.CreateItemFromTemplate(path1 & filename)

oMail.Display
subject1 = oMail.subject
subject1 = Left(subject1, Len(subject1) - 10) & 
Format(ThisWorkbook.Worksheets(1).Range("D7"), "DD/MM/YYYY")

Dim currwatcher As EmailWatcher
Set currwatcher = New EmailWatcher
currwatcher.INIT oMail
Set currwatcher.themail = oMail

Set wbk = Workbooks.Open(filename:=path2 & wb)

wbk.Worksheets(1).Range("I4") = ThisWorkbook.Worksheets(1).Range("D7").Value
wbk.Close True
ThisWorkbook.Worksheets(1).Cells(r, c + 4) = subject1
With oMail
    .subject = subject1
    .Attachments.Add (path2 & wb)
End With
With ThisWorkbook.Worksheets(1).Cells(r, c - 2)
    .Value = Now
    .Font.Color = vbWhite
End With
With ThisWorkbook.Worksheets(1).Cells(r, c - 1)
    .Value = "Was opened"
    .Select
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub