我在 VBA 編碼方面的經驗為零，但我目前有一個我在網上某處復制的有效代碼，它成功地從每封電子郵件中提取了某些細節。我想知道是否可以補充或修改代碼以包括收件人的電子郵件地址以及抄送串列中的電子郵件地址。代碼如下 -
Sub FetchEmailData()
Dim appOutlook As Object
Dim olNs As Object
Dim olFolder As Object
Dim olItem As Object
Dim iRow As Integer
' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olNs = appOutlook.getnamespace("MAPI")
'Set olFolder = olNs.GetDefaultFolder(6) ' 6 == Inbox for some reason
Set olFolder = olNs.session.PickFolder
' Clear
ThisWorkbook.ActiveSheet.Cells.Delete
' Build headings:
Range("A1:E1") = Array("From:", "To:", "CC:", "Date", "SenderEmailAddress")
For iRow = 1 To olFolder.items.Count
Cells(iRow 1, 1) = olFolder.items.Item(iRow).Sender
Cells(iRow 1, 2) = olFolder.items.Item(iRow).To
Cells(iRow 1, 3) = olFolder.items.Item(iRow).CC
Cells(iRow 1, 4) = olFolder.items.Item(iRow).receivedtime
If olFolder.items.Item(iRow).SenderEmailType = "EX" Then
Cells(iRow 1, 5) = olFolder.items.Item(iRow).Sender.GetExchangeUser().PrimarySmtpAddress
Else
On Error Resume Next
Cells(iRow 1, 5) = olFolder.items.Item(iRow).SenderEmailAddress
End If
Next iRow
End Sub
uj5u.com熱心網友回復：
這演示了如何應用 如何從 Outlook 的“收件人”欄位中提取電子郵件地址中的一個可能答案？.
Option Explicit
Sub FetchEmailData_Call_smtpAddress()
Dim appOutlook As Object
Dim olNs As Object
Dim olFolder As Object
Dim olItem As Object
Dim iRow As Long
' Get/create Outlook Application
On Error Resume Next
Set appOutlook = GetObject(, "Outlook.Application")
If appOutlook Is Nothing Then
Set appOutlook = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olNs = appOutlook.getnamespace("MAPI")
Set olFolder = olNs.PickFolder
If olFolder Is Nothing Then
Debug.Print "User cancelled."
Exit Sub
End If
' Clear
ThisWorkbook.ActiveSheet.Cells.Delete
' Build headings:
Range("A1:E1") = Array("From:", "To:", "CC:", "Date", "SenderEmailAddress")
For iRow = 1 To olFolder.items.Count
Set olItem = olFolder.items.Item(iRow)
With olItem
Cells(iRow 1, 1) = .Sender
Cells(iRow 1, 2) = .To
Cells(iRow 1, 3) = .CC
Cells(iRow 1, 4) = .receivedtime
If olFolder.items.Item(iRow).SenderEmailType = "EX" Then
Cells(iRow 1, 5) = .Sender.GetExchangeUser().PrimarySmtpAddress
Else
On Error Resume Next
Cells(iRow 1, 5) = .SenderEmailAddress
On Error GoTo 0 ' consider mandatory
End If
' Pass the item to smtpAddress
smtpAddress olItem
' You could move the smtpAddress code into the main sub.
' Entering the email addresses in the next empty cells in the row, should be easier.
End With
Next iRow
ThisWorkbook.ActiveSheet.Columns.AutoFit
Debug.Print "Done."
End Sub
Private Sub smtpAddress(ByVal Item As Object)
' https://stackoverflow.com/a/12642193/1571407
Dim addrRecips As Object ' Outlook.Recipients
Dim addrRecip As Object ' Outlook.Recipient
Dim pa As Object ' Outlook.propertyAccessor
' This URL cannot be clicked nor pasted into a browser.
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set addrRecips = Item.Recipients
For Each addrRecip In addrRecips
Set pa = addrRecip.PropertyAccessor
Debug.Print pa.GetProperty(PR_SMTP_ADDRESS)
Next
End Sub
uj5u.com熱心網友回復：
您可以使用該Recipients屬性來獲取 Outlook 中特定郵件專案的所有收件人。Recipient.Type屬性回傳或設定一個表示接收者型別的長整數。對于郵件專案的值顯示在OlMailRecipientType 列舉中：
olBCC- 3 - 收件人在BCC專案的屬性中指定。olCC- 2 - 收件人在CC專案的屬性中指定。olOriginator- 0 -Originator專案的（發件人）。olTo- 1 - 收件人在To專案的屬性中指定。
因此，您可能會找到與 CC 欄位對應的 Recipient 物件，并使用Recipient.AddressEntry屬性回傳AddressEntry與已決議收件人對應的物件。
Set myAddressEntry = myRecipient.AddressEntry
AddressEntry.Address屬性回傳或設定一個字串，該字串表示AddressEntry. 對于 Exchange 帳戶，您可以使用AddressEntry.GetExchangeUser方法，該方法回傳一個ExchangeUser物件，該物件表示該物件AddressEntry是否AddressEntry屬于AddressList諸如全域地址串列 (GAL) 之類的 Exchange 物件并對應于 Exchange 用戶。在這種情況下，ExchangeUser.PrimarySmtpAddress屬性回傳一個字串，該字串表示ExchangeUser.
您可能會發現如何：以編程方式填寫 Outlook 中的收件人、抄送和密件抄送欄位一文很有幫助。
轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/472957.html
上一篇：需要在下拉串列中捕獲已發布的值