Question

我使用下面的代码在Exchange Outlook 2016和360上记录收件电子邮件。但是有一些我无法解决的问题。我希望它也能记录用户发送的电子邮件（SMPT地址），并在我正在使用的工作表上放置一个标识符，以显示它是出站电子邮件还是入站电子邮件。另外，在某个时刻，宏会将Outlook应用程序冻结了几秒钟，这可能会烦人。。最后，如果宏每天都可以发送电子邮件地址Messagelog.xlsx文件，就可以了。


Public WithEvents objMails As Outlook.Items

Private Sub Application_Startup()
    Set objMails = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub objMails_ItemAdd(ByVal Item As Object)
    Dim objMail As Outlook.MailItem
    Dim strExcelFile As String
    Dim objExcelApp As Excel.Application
    Dim objExcelWorkBook As Excel.Workbook
    Dim objExcelWorkSheet As Excel.Worksheet
    Dim nNextEmptyRow As Integer
    Dim strColumnB As String
    Dim strColumnC As String
    Dim strColumnD As String
    Dim strColumnE As String

    If Item.Class = olMail Then
       Set objMail = Item
    End If

    'Specify the Excel file which you want to auto export the email list
    'You can change it as per your case
    strExcelFile = "C:\ETracker\MessageLog.xlsx"

    'Get Access to the Excel file
    On Error Resume Next
    Set objExcelApp = GetObject(, "Excel.Application")
    If Error <> 0 Then
       Set objExcelApp = CreateObject("Excel.Application")
    End If
    Set objExcelWorkBook = objExcelApp.Workbooks.Open(strExcelFile)
    Set objExcelWorkSheet = objExcelWorkBook.Sheets("Received")

    'Get the next empty row in the Excel worksheet
    nNextEmptyRow = objExcelWorkSheet.Range("B" & objExcelWorkSheet.Rows.Count).End(xlUp).Row + 1

    'Specify the corresponding values in the different columns
    strColumnB = objMail.SenderName
    strColumnC = objMail.SenderEmailAddress
    strColumnD = objMail.Subject
    strColumnE = objMail.ReceivedTime

    'Add the vaules into the columns
    objExcelWorkSheet.Range("A" & nNextEmptyRow) = nNextEmptyRow - 1
    objExcelWorkSheet.Range("B" & nNextEmptyRow) = strColumnB
    objExcelWorkSheet.Range("C" & nNextEmptyRow) = strColumnC
    objExcelWorkSheet.Range("D" & nNextEmptyRow) = strColumnD
    objExcelWorkSheet.Range("E" & nNextEmptyRow) = strColumnE

    'Fit the columns from A to E
    objExcelWorkSheet.Columns("A:E").AutoFit

    'Save the changes and close the Excel file
    objExcelWorkBook.Close SaveChanges:=True
End Sub

我想在记录的信息显示方面表现出色，谁发送了电子邮件，收件人，主题和时间戳，入站/出站标记

Answer 1

如果要记录已发送的电子邮件，请捕获Application.ItemSend事件。但是，要在一天的特定时间自动发送电子邮件，VBA宏会受到很大限制。一种技巧是使用具有提醒时间的重复任务，并在Application.Reminder事件中查找该特定任务，然后触发您的宏。否则，您必须将其设计为COM加载项，并使用某种.NET计时器组件。

获取此代码也可以记录出站电子邮件

1 个答案: