EXCEL VBA，Outlook手動電子郵件發件人，類模塊問題

Question

我仍在處理我在有關該主題的第一個問題中描述的問題 。 為了簡短刷新，它是一個excel文件，其中包含電子郵件模板和附件的列表，向每個列表單元添加了按鈕，該按鈕打開給定單元的模板，進行一些更改，然后附加文件並將郵件顯示到用戶。 用戶可以根據需要修改郵件，然后發送或不發送郵件。 我嘗試了以下幾種方法。 不幸的是，我現在停滯在類模塊的問題上， 這里簡短介紹一下 。 我確實已經創建了一個類模塊，例如“ EmailWatcher”，甚至與此處描述的方法進行了較小的組合：

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

Dim CurrWatcher As EmailWatcher

該行必須是全局的，在任何子例程之外。

Answer 2

我在這里回答了類似的問題，並仔細研究了一下，我認為當您步入正軌時，您的實現存在一些錯誤。 嘗試以下方法：

執行類模塊，因此，擺脫不必要的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中監視，並且對此對象（通過VBA）調用.Send方法或手動發送電子郵件應引發TheMail_Send事件過程。

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