时间戳

首页 > 解决方案 > 获取此代码以记录出站电子邮件

excel - 获取此代码以记录出站电子邮件

问题描述

我已经使用下面的代码在 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

我想要一个带有记录信息显示的excel，谁发送了电子邮件，收件人，主题和时间戳，入站/出站标记

标签： excelvbaoutlook

解决方案

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

推荐阅读