将邮件标题字段导出到 Excel

大佬教程收集整理的这篇文章主要介绍了将邮件标题字段导出到 Excel，大佬教程大佬觉得挺不错的，现在分享给大家，也给大家做个参考。

如何解决将邮件标题字段导出到 Excel？

我从 Outlook 文件夹中导出电子邮件元数据，例如发件人、收件人、主题、接收日期等。

我从 https://www.vishalon.net/blog/export-outlook-from-to-subject-receive-date-and-other-meta-data-into-excel 找到了这个代码：

@H_618_7@Option Explicit

Sub GetMailinfo()

Dim results() As String

  ' get contacts
  results = ExportEmails(true)

  ' paste onto worksheet
  Range(Cells(1,1),Cells(UBound(results),UBound(results,2))).Value = results

    MsgBox "Completed"
End Sub

Function ExportEmails(Optional headerRow As Boolean = falsE) As String()

Dim objOutlook As Object ' outlook.application
Dim objnamespace As Object ' Outlook.namespace
Dim strFoldername As Object
Dim objMailBox As Object
Dim objFolder As Object
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As Object
Dim msg As Object ' Outlook.Mailitem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
Dim deBUGMsg As Integer

' SELEct output results worksheet and clear prevIoUs results
Sheets("Outlook Results").SELEct
Sheets("Outlook Results").Cells.ClearContents
Range("A1").SELEct

Set objOutlook = CreateObject("outlook.application")
'MsgBox objOutlook,vbOKOnly 'for deBUGging
Set objnamespace = objOutlook.Getnamespace("MAPI")
'MsgBox objnamespace,vbOKOnly 'for deBUGging
'Set objInBox = objnamespace.GetDefaultFolder(olFolderInBoX)
'MsgBox objInBox,vbOKOnly 'for deBUGging
Set strFoldername = objnamespace.PickFolder
Set mailFolderItems = strFoldername.Items

  ' if calling procedure wants header row
  If headerRow Then
    startRow = 1
  Else
    startRow = 0
  End If

  numRows = mailFolderItems.Count

  ' resize array
  ReDim tempString(1 To (numRows + startRow),1 To 100)

  ' loop through folder items
  For i = 1 To numRows
    Set folderItem = mailFolderItems.Item(i)

    If Ismail(folderItem) Then
      Set msg = folderItem
    End If

    With msg
      tempString(i + startRow,1) = .bCC
      tempString(i + startRow,2) = .billinginformation
      tempString(i + startRow,3) = left$(.body,900)  ' throws error without limit
      tempString(i + startRow,4) = .bodyFormat
      tempString(i + startRow,5) = .CategorIEs
      tempString(i + startRow,6) = .cc
      tempString(i + startRow,7) = .CompanIEs
      tempString(i + startRow,8) = .CreationTime
      tempString(i + startRow,9) = .DeferredDeliveryTime
      tempString(i + startRow,10) = .deleteAftersubmit
      tempString(i + startRow,11) = .ExpiryTime
      tempString(i + startRow,12) = .FlagDueBy
      tempString(i + startRow,13) = .FlagIcon
      tempString(i + startRow,14) = .Flagrequest
      tempString(i + startRow,15) = .FlagStatus
      tempString(i + startRow,16) = .importance
      tempString(i + startRow,17) = .LastModificationTime
      tempString(i + startRow,18) = .Mileage
      tempString(i + startRow,19) = .originatorDeliveryReportrequested
      tempString(i + startRow,20) = .Permission
      tempString(i + startRow,21) = .ReadReceiptrequested
      tempString(i + startRow,22) = .ReceivedByname
      tempString(i + startRow,23) = .ReceivedOnBehalfOfname
      tempString(i + startRow,24) = .ReceivedTime
      tempString(i + startRow,25) = .RecipIEntReassignmentProhibited
      tempString(i + startRow,26) = .ReminderSet
      tempString(i + startRow,27) = .ReminderTime
      tempString(i + startRow,28) = .ReplyRecipIEntnames
      tempString(i + startRow,29) = .SenderEmailAddress
      tempString(i + startRow,30) = .SenderEmailType
      tempString(i + startRow,31) = .Sendername
      tempString(i + startRow,32) = .Sensitivity
      tempString(i + startRow,33) = .SentOn
      tempString(i + startRow,34) = .Size
      tempString(i + startRow,35) = .Subject
      tempString(i + startRow,36) = .To
      tempString(i + startRow,37) = .VoTingOptions
      tempString(i + startRow,38) = .VoTingResponse
      tempString(i + startRow,39) = .Attachments.Count
      tempString(i + startRow,40) = .CIP
      tempString(i + startRow,41) = .CTRY

    End With

    ' adding file attachment names where they exist - added by JP
    If msg.Attachments.Count > 0 Then

        For jAttach = 1 To msg.Attachments.Count
            tempString(i + startRow,39 + jAttach) = msg.Attachments.Item(jAttach).displayname
        Next jAttach

    End If

  Next i

  ' first row of array should be header values
  If headerRow Then

    tempString(1,1) = "BCC"
    tempString(1,2) = "Billinginformation"
    tempString(1,3) = "Body"
    tempString(1,4) = "BodyFormat"
    tempString(1,5) = "CategorIEs"
    tempString(1,6) = "cc"
    tempString(1,7) = "CompanIEs"
    tempString(1,8) = "CreationTime"
    tempString(1,9) = "DeferredDeliveryTime"
    tempString(1,10) = "deleteAftersubmit"
    tempString(1,11) = "ExpiryTime"
    tempString(1,12) = "FlagDueBy"
    tempString(1,13) = "FlagIcon"
    tempString(1,14) = "Flagrequest"
    tempString(1,15) = "FlagStatus"
    tempString(1,16) = "importance"
    tempString(1,17) = "LastModificationTime"
    tempString(1,18) = "Mileage"
    tempString(1,19) = "OriginatorDeliveryReportrequested"
    tempString(1,20) = "Permission"
    tempString(1,21) = "ReadReceiptrequested"
    tempString(1,22) = "ReceivedByname"
    tempString(1,23) = "ReceivedOnBehalfOfname"
    tempString(1,24) = "ReceivedTime"
    tempString(1,25) = "RecipIEntReassignmentProhibited"
    tempString(1,26) = "ReminderSet"
    tempString(1,27) = "ReminderTime"
    tempString(1,28) = "ReplyRecipIEntnames"
    tempString(1,29) = "SenderEmailAddress"
    tempString(1,30) = "SenderEmailType"
    tempString(1,31) = "Sendername"
    tempString(1,32) = "Sensitivity"
    tempString(1,33) = "SentOn"
    tempString(1,34) = "size"
    tempString(1,35) = "subject"
    tempString(1,36) = "To"
    tempString(1,37) = "VoTingOptions"
    tempString(1,38) = "VoTingResponse"
    tempString(1,39) = "number of Attachments"
    tempString(1,40) = "Attachment 1 filename"
    tempString(1,41) = "Attachment 2 filename"
    tempString(1,42) = "cip"
    tempString(1,43) = "ctry"
  End If

  ExportEmails = tempString

  ' apply pane freeze and filtering

    Range("A2").SELEct
    ActiveWindow.FreezePanes = True
    Rows("1:1").SELEct
    'SELEction.autoFilter

End Function

Function Ismail(itm As Object) As Boolean
  Ismail = (Typename(itm) = "Mailitem")
End Function

我需要从消息头中获取连接 IP 地址 (CIp) 和国家 (CTRY)，此外，如果 SPF、DKIM 和 Dmarc 通过（spf=pass、dkim=pass 和 dmarc=pass）。

我添加了以下内容（不知道如何添加 SPF、DKIM 和 Dmarc 部分）：

@H_618_7@    tempString(i + startRow,40) = .CIP
    tempString(i + startRow,41) = .CTRY

    tempString(1,42) = "CIP"
    tempString(1,43) = "CTRY"

我明白了：

运行时错误“438”：
对象不支持此属性方法

我如何获得 CIP、CTRY、SPF、DKIM 和 Dmarc？

解决方法

@H_618_7@Option Explicit

Private Sub ShowPropertyAssessorResult()

    ' https://www.slipstick.com/developer/read-mapi-properties-exposed-outlooks-object-model/
    
    Dim oItem As Object
    Dim propertyAccessor As propertyAccessor
    
    Set oItem = ActiveExplorer.SELEction.item(1)
    Set propertyAccessor = oItem.propertyAccessor
    
    If oItem.Class = olMail Then
        Debug.Print "Sender Display name: " & oItem.sender
        Debug.Print "Sender address: " & oItem.SenderEmailAddress
        
        ' Internet headers
        Debug.Print "PR_TRANSPORT_messaGE_HEADERS",propertyAccessor.GetProperty("http://scheR_365_11845@as.microsoft.com/mapi/proptag/0x007D001E")
    End If
    
End Sub

大佬总结

以上是大佬教程为你收集整理的将邮件标题字段导出到 Excel全部内容，希望文章能够帮你解决将邮件标题字段导出到 Excel所遇到的程序开发问题。

如果觉得大佬教程网站内容还不错，欢迎将大佬教程推荐给程序员好友。

本图文内容来源于网友网络收集整理提供，作为学习参考使用，版权属于原作者。
如您有任何意见或建议可联系处理。小编QQ：384754419，请注明来意。