Question

我需要从头开始。我只有手臂才有代码。我“只是”想弄清楚如何确定发送电子邮件的日期并将其插入Excel中的特定列。我已经弄清楚了如何在电子邮件正文中获取HTML表并将其放在Excel中。现在，我要做的“全部”就是捕获电子邮件的日期并放入列

Public Sub Driver()

    Dim Item As MailItem, x%
    Dim r As Object                              'As Word.Range
    Dim doc As Object                            'As Word.Document
    Dim xlApp As Object
    Dim olItems As Outlook.Items
    Dim sourceWB As Workbook
    Dim sourceSH As Worksheet
    Dim olFolder As Outlook.Folder
    Dim strFile As String
    Dim olEleColl As MSHTML.IHTMLElementCollection
    Dim olNameSpace As Outlook.NameSpace
    Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
    Dim OutlookApp As Object
    Dim OutlookMail As Object

    Dim objEmail As Outlook.MailItem
    Dim intRowIndex As Integer
    Dim intEmailIndex As Integer
    Dim objFolder As Outlook.MAPIFolder

    Set xlApp = CreateObject("Excel.Application")
    With xlApp
        .Visible = True
        .EnableEvents = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    Set olNameSpace = Application.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
    Set olItems = olFolder.Items
    'olItems.Sort ("[ReceivedTime]")
    Set Item = olItems(olItems.Count)

    'save Outlook email's html body (tables)
    With olHTML
        .Body.innerHTML = Item.HTMLBody
        Set olEleColl = .getElementsByTagName("table")
    End With

    strFile = "C:\xls\Driver.xlsx"

    Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
    Set sourceSH = sourceWB.Worksheets("Sheet1")
    sourceWB.Activate

    cells.Select
    Selection.Delete

    For Each Item In Application.ActiveExplorer.Selection
        Set doc = Item.GetInspector.WordEditor

        For x = 1 To doc.tables.Count
            Set r = doc.tables(x)
            r.Range.Copy
            sourceSH.Paste

            ActiveSheet.Pictures.Delete
            rows(4).Delete
            rows(1).EntireRow.Delete
            rows(1).EntireRow.Delete
            rows(1).EntireRow.Delete
            Range("D:E").Delete

            sourceSH.cells(sourceSH.rows.Count, 1).End(3).Offset(1).Select

            sourceSH.cells(1, 4) = "Received Time"

        Next
    Next

    sourceWB.Save
    sourceWB.Close

    Set sourceWB = Nothing
    xlApp.Quit
    Set xlApp = Nothing

    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)

    On Error Resume Next
    With OutlookMail
        .To = "me@memememe.com"

        .CC = ""
        .BCC = ""
        .Subject = "If this works!"
        .Body = "Test."
        .Attachments.Add ("c:\xls\Driver.xlsx")
        .Send
    End With

    Set OutlookMail = Nothing
    Set OutlookApp = Nothing

End Sub

Answer 1

您可以使用MailItem.ReceivedTime属性获取电子邮件的时间。

请尝试以下代码。

    Public Sub Driver()
    Dim xlApp As Object
    Dim sourceWB As Workbook
    Dim strFile As String
    Dim olItems As Outlook.Items
    Dim sourceSH As Worksheet
    Dim olFolder As Outlook.folder
    Dim olNameSpace As Outlook.NameSpace
    Dim objEmail As Object
    Dim intRowIndex As Integer
    Dim intEmailIndex As Integer
    Dim objFolder As Outlook.MAPIFolder
    Dim m As Long
    Set xlApp = CreateObject("Excel.Application")
    With xlApp
        .Visible = True
        .EnableEvents = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    Set olNameSpace = Application.GetNamespace("MAPI")
    Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
    Set olItems = olFolder.Items
    'olItems.Sort ("[ReceivedTime]")
    strFile = "C:\Users\dfddg\Desktop\Book1.xlsx"
    Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
    Set sourceSH = sourceWB.Worksheets("Sheet1")
    sourceWB.Activate
    m = 1
    For Each Item In olItems
    sourceSH.cells(m, 4) = Item.ReceivedTime
    'MsgBox Item.ReceivedTime
    'MsgBox Item.Subject
    m = m + 1
    Next
    sourceWB.Save
    sourceWB.Close
End Sub

Answer 2

好的，我发现可能不建议这样做，但是对我有用。我添加了一个specialcells函数，该函数搜索列中的空白单元格，然后添加所需的日期。非常感谢您的所有帮助

Public Sub Driver()


Dim Item As MailItem, x%
Dim r As Object  'As Word.Range
Dim doc As Object 'As Word.Document
Dim xlApp As Object
Dim olItems As Outlook.Items
Dim sourceWB As Workbook
Dim sourceSH As Worksheet
Dim olFolder As Outlook.Folder
Dim strFile As String
Dim olEleColl As MSHTML.IHTMLElementCollection
Dim olNameSpace As Outlook.NameSpace
Dim olHTML As MSHTML.HTMLDocument: Set olHTML = New MSHTML.HTMLDocument
Dim OutlookApp As Object
Dim OutlookMail As Object

Dim objEmail As Outlook.MailItem
Dim intRowIndex As Integer
Dim intEmailIndex As Integer
Dim objFolder As Outlook.MAPIFolder

Set xlApp = CreateObject("Excel.Application")
    With xlApp
        .Visible = True
        .EnableEvents = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With
    Set olNameSpace = Application.GetNamespace("MAPI")

Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox)
Set olItems = olFolder.Items
'olItems.Sort ("[ReceivedTime]")
Set Item = olItems(olItems.Count)

'save Outlook email's html body (tables)
With olHTML
    .Body.innerHTML = Item.HTMLBody
    Set olEleColl = .getElementsByTagName("table")
End With

strFile = "C:\xls\Driver.xlsx"

 Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
 Set sourceSH = sourceWB.Worksheets("Sheet1")
    sourceWB.Activate

cells.Select
    Selection.Delete

For Each Item In Application.ActiveExplorer.Selection
Set doc = Item.GetInspector.WordEditor
    For x = 1 To doc.tables.Count
     Set r = doc.tables(x)


        r.Range.Copy
       sourceSH.Paste
ActiveSheet.Pictures.Delete
rows(4).Delete
    rows(1).EntireRow.Delete
    rows(1).EntireRow.Delete
    rows(1).EntireRow.Delete
 Range("D:E").Delete
       sourceSH.cells(sourceSH.rows.Count, 1).End(3).Offset(1).Select


sourceSH.cells(2, 4) = Item.ReceivedTime
sourceSH.cells(1, 4) = "Received Time"
Range("D2").CurrentRegion.SpecialCells(xlCellTypeBlanks).Value = Item.ReceivedTime


    Next
Next
End Sub

在Excel电子表格中捕获电子邮件的接收时间

2 个答案: