EXCEL VBA, ручной отправитель электронной почты Outlook, выпуск класса Class

Я все еще работаю над проблемой, которую я описал в своем первом вопросе по этой теме. Для краткого обновления, это файл 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. Класс заканчивается в конце подпрограммы. Оставить письмо полностью пользователю. Вопрос в том, где ошибка? Или как оставить модуль класса в так называемом "режиме ожидания", или, может быть, есть другие предложения? Я также рассматриваю способ поиска почты в "исходящих" сообщениях, но подход с событием "Отправить" гораздо предпочтительнее.

Источник

3 ответа

Решение

Я ответил на аналогичный вопрос здесь и, глядя на него, думаю, что, хотя вы на правильном пути, у вас есть несколько ошибок в вашей реализации. Попробуйте это вместо этого:

Сделайте модуль 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 процедура события.

Источник

Dim CurrWatcher As EmailWatcher

Эта строка должна быть глобальной, вне каких-либо подпрограмм.

Источник

Большое спасибо за помощь и поддержку, я наконец сделал это.

Поскольку я использую шаблоны писем, требуется время, чтобы понять, как добавить их в коллекцию.

Вот мое решение. Модуль класса:

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
Источник
Другие вопросы по тегам