Question

我在Windows 10上的MS Access 2013和MS Outlook 2013中工作，我有一个带有＆＃34;导航子类型的访问数据库＆＃34;允许在两个不同的场合发送单个电子邮件的范例。

我正在尝试编写代码来执行以下操作：

发送新电子邮件时
我想将它自动保存为磁盘上的.msg文件。

据我所知，似乎这样做的方法是通过捕获在Access中的Outlook发送文件夹上触发的.ItemAdd事件，并在那里执行.SaveAs方法。

我试图根据这两个答案实施解决方案：

How to Trap Outlook Events from Excel Application

Utilizing Outlook Events From Excel

但我似乎无法将两者结合起来并使事件发生。

我的感觉是要么我没有正确引用/设置内容，要么在电子邮件从发件箱文件夹移动到已发送文件夹之前执行结束，但我和＃39;我不确定。

我该怎么做？

感谢阅读，代码如下：

我当前的课程模块 - ＆＃34; cSentFolderItem＆＃34;

Option Explicit

Public WithEvents myOlItems As Outlook.items

Private Sub Class_Initialize()

    Dim oNS As NameSpace
    Dim myOL As Outlook.Application

    Set myOL = New Outlook.Application
    Set oNS = myOL.GetNamespace("MAPI")
    Set myOlItems = oNS.GetDefaultFolder(olFolderSentMail).items

End Sub


Private Sub myOlItems_ItemAdd(ByVal Item As Object)
    Debug.Print "I got a new item on Sent box!"
    Dim myOlMItem As Outlook.MailItem

    Set myItem = myOlItems.items(email_subject)
    myItem.Display

    myItem.SaveAs "C:\Users\XXXXXX\Desktop\mail_test.msg", olMSGUnicode

End Sub

＆＃34;定期＆＃34;代码：

Public Function GetApplication(Class As String) As Object
    'Handles creating/getting the instance of an application class
    Dim ret As Object

    On Error Resume Next

    Set ret = GetObject(, Class)
    If Err.Number <> 0 Then
        Set ret = CreateObject(Class)
    End If

    Set GetApplication = ret

    On Error GoTo 0

End Function


Sub Test()
    email_subject = "Mail test match string - [aaaa-mm-dd]"

    Set myOlItems = New cSentFolderItem 'declare class module object

    Dim MyOutlook As Outlook.Application
    Set MyOutlook = GetApplication("Outlook.Application") 'trying to get correct application object

    'The following code is a dummy e-mail creation, after which I press SEND:
    Dim MyMail As Outlook.MailItem

    varTo = "target_email@address.com"
    varSubject = email_subject
    varbody = "test line 1" & vbCrLf & "test line 2" & vbCrLf & "test line 2"

    varSubject = Replace(varSubject, "[aaaa-mm-dd]", NOW())

    Dim linhas() As String
    linhas = Split(varbody, vbCrLf)

    bodyHTMLtext = "<body>"
    For i = 0 To UBound(linhas) - 1
        bodyHTMLtext = bodyHTMLtext & linhas(i) & "<br>"
    Next

    bodyHTMLtext = bodyHTMLtext & linhas(UBound(linhas))
    bodyHTMLtext = bodyHTMLtext & "</body>"

    Set MyMail = MyOutlook.CreateItem(OLMAILITEM)

    MyMail.To = varTo
    MyMail.Subject = varSubject

    MyMail.Display

    MyMail.HTMLBody = bodyHTMLtext & MyMail.HTMLBody

    AppActivate varSubject

    'trying to leave Outlook object open:
    ''Cleanup after ourselves
    'Set MyMail = Nothing

    ''MyOutlook.Quit
    'Set MyOutlook = Nothing        

End Sub

Answer 1

好的，经过一段很长时间后，我发现了它，并得到了以下解决方案。

我的课程模块“MyOutlook”是：

Option Explicit

Public myOutlookApp As Outlook.Application
Public mySentFolder As Outlook.Folder
Public WithEvents myItems As Outlook.items

Private Sub Class_Initialize()

    Set myOutlookApp = GetApplication("Outlook.Application")

    Dim oNS As NameSpace
    Set oNS = myOutlookApp.GetNamespace("MAPI")
    Set mySentFolder = oNS.GetDefaultFolder(olFolderSentMail)
    Set myItems = mySentFolder.items

End Sub

Private Sub myItems_ItemAdd(ByVal Item As Object)

    Debug.Print "Got_EMAIL!!! Looking for subject = " & email_subject
    '"e-mail_subject" is Public a string, assigned in another part of the program

    If Item.Subject = email_subject Then 
        Item.SaveAs "C:\Users\640344\Desktop\mail_test.msg", olMSGUnicode
    End If

End Sub

GetApplication的位置：

Function GetApplication(Class As String) As Object
    'Handles creating/getting the instance of an application class
    'If there exists one already (in my case, Outlook already open),
    'it gets its name, else it creates one

    Dim ret As Object

    On Error Resume Next

    Set ret = GetObject(, Class)
    If Err.Number <> 0 Then
        Set ret = CreateObject(Class)
        If Class = "Outlook.Application" Then
            'Outlook wasn't opened, so open it
            ret.Session.GetDefaultFolder(olFolderInbox).Display
            ret.ActiveExplorer.WindowState = olMaximized
            ret.ActiveExplorer.WindowState = olMinimized
        End If
    End If

    Set GetApplication = ret

    On Error GoTo 0

End Function

请注意，我在'Outlook未打开后添加了3行代码，因此打开它，否则我会收到错误。无论如何，我的用户打开Outlook并不是一个坏主意。

在我的项目的“常规”代码部分，在任何程序之外，我声明：

Public myOutlook As myOutlook

然后，在我的项目的“主要”子上：

Set myOutlook = New myOutlook
'[...]
'Code where entire program runs
'[...]
Set myOutlook = Nothing

这样，myOutlook对象（及其变量）在程序（及其导航表单）运行的整个时间内“存在”，并等待在Outlook的默认已发送文件夹上捕获_ItemAdd事件。

请注意，我只查找主题等于email_subject字符串的电子邮件，因为我不想保存所有已发送的电子邮件，只是保存使用该程序发送的电子邮件，并且我有代码来分配我的电子邮件希望服从该字符串。

从Access

1 个答案: