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 

最後我做了這是工作的一類，我已經把一些控件，以檢查它，你可以從類看冒頓le代碼。但問題是，它沒有捕獲發送事件。這個類在sub的結尾處終止。將電子郵件完全留給用戶。問題是：哪裏出錯？或者如何在所謂的「等待模式」下離開課程模塊，或者其他建議？ 我也考慮在'發件箱'中搜索郵件的方式，但發送事件的方式更受青睞。

Answer 1

我回答了一個類似的問題here並仔細查看了一下，我認爲，當你在正確的軌道上時，你的實現有一些問題。試試這個：

做類模塊，如此，擺脫不必要的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