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

Question

I am still working on the problem that I have described in my 1st question on this topic. For short refresh, it is an excel file which contains the list of email templates and attachments, to each list unit I have add the button which opens the template of the giving unit make there some changes, then attaches files and display the mail to the User. User can amend mail if necessary and then send or not to send mail. I have tried several approaches described below. Unfortunately, I am stalled now on the issue with class module, that shortly described here . I do have created a class module, such as 'EmailWatcher' and even make a small combination with method described 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

The change to following form does not make any change:

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

The module code is as follow:

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

Finally I have made a class which is working and I have put some controls to check it as you can see from class module code. But the problem is, it does not catch the Send event. The class is terminating at the end of the sub. Leaving the email fully to User. The question is: where is mistake? Or how to leave the class module in so called "waiting mode", or maybe any other suggestions? I so also consider the way to search for mails in the 'outbox' but the approach with Send event is much more in favour.

Answer 1

Dim CurrWatcher As EmailWatcher

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

Answer 2

I answered a similar question here and looking over that, I think that while you're on the right track, you've got a few things wrong with your implementation. Try this instead:

Do the Class module as so, get rid of the unnecessary INIT procedure and use the Class_Initialize procedure to create the 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

Example for use in normal module, tested & confirmed this is working and will handle multiple emails (which my previous answer didn't accomplish).

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

How's it work? First, we make sure we have an Outlook.Application instance to work with. This will be scoped as a Public in module so it will be available to other procedures & classes.

Then, we create a new instance of our EmailWatcher class, which raises the Class_Initialize event. We leverage this event, and the already handled instance of Outlook.Application to create & assign the TheMail object event handler.

We store these in a Public collection so that they remain in scope even after the SendMail procedure runtime is over. This way you can create several emails and they will all have their events monitored.

From that point on, thisMail.TheMail represents the MailItem whose events are being monitored under Excel, and invoking the .Send method on this object (via VBA) or manually sending the email should raise the TheMail_Send event procedure.

Answer 3

Thanks a lot for help and support, I have finally done it.

As I do use templates of the mails it takes some time to figure out how to add them to collection.

Here is my solution. Class module:

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

Module:

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