vba 从 Outlook 中提取电子邮件地址
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/7941191/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
extract email address from outlook
提问by air
I am trying to extract email addresses of all emails in my Outlook inbox. I found this code on the Internet.
我正在尝试提取 Outlook 收件箱中所有电子邮件的电子邮件地址。我在网上找到了这段代码。
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
''' Requires reference to Microsoft Scripting Runtime
Dim dic As New Dictionary
Dim objItem As Object
''Set objFolder = Application.ActiveExplorer.Selection
Set objFolder = Application.GetNamespace("Mapi").PickFolder
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not dic.Exists(strEmail) Then
strEmails = strEmails + strEmail + vbCrLf
dic.Add strEmail, ""
End If
I am using outlook 2007. When I run this code from the Outlook Visual Basic Editor with F5 I get an error on the following line.
我使用的是 Outlook 2007。当我使用 F5 从 Outlook Visual Basic 编辑器运行此代码时，我在以下行中收到错误消息。
Dim dic As New Dictionary
"user defined type not defined"
回答by brettdj
I have provided updated code below
我在下面提供了更新的代码
- to dump the Inbox email addresses to a CSV file "c:\emails.csv" (the current code provides no "outlook" for the collected addresses
- the code above works on a selected folder rather than Inbox as per your request
- 将收件箱电子邮件地址转储到 CSV 文件“ c:\emails.csv”（当前代码不提供收集地址的“外观”
- 上面的代码根据您的要求适用于选定的文件夹而不是收件箱
[Update: For clarity this is your old code that uses "early binding", setting this reference is unnecessary for my updated code below which uses "late binding"]
[更新：为清楚起见，这是您使用“早期绑定”的旧代码，对于下面使用“后期绑定”的更新代码，不需要设置此引用]
Part A: Your existing code (early binding)
A 部分：您现有的代码（早期绑定）
In terms of the error you received:
就您收到的错误而言：
The code sample aboves uses early binding, this comment "Requires reference to Microsoft Scripting Runtime"indciates that you need to set the reference
上面的代码示例使用了早期绑定，此注释“需要对 Microsoft Scripting Runtime 的引用”表明您需要设置引用
- Goto the Tools menu
- Select 'References'
- check "Microdoft Scripting Runtime"
- 转到工具菜单
- 选择“参考”
- 检查“Microdoft 脚本运行时”
Part B: My new code (late binding - setting the reference is unnecessary)
B 部分：我的新代码（后期绑定 - 不需要设置引用）
Working Code
工作代码
Sub GetALLEmailAddresses()
Dim objFolder As MAPIFolder
Dim strEmail As String
Dim strEmails As String
Dim objDic As Object
Dim objItem As Object
Dim objFSO As Object
Dim objTF As Object
Set objDic = CreateObject("scripting.dictionary")
Set objFSO = CreateObject("scripting.filesystemobject")
Set objTF = objFSO.createtextfile("C:\emails.csv", 2)
Set objFolder = Application.GetNamespace("Mapi").GetDefaultFolder(olFolderInbox)
For Each objItem In objFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
If Not objDic.Exists(strEmail) Then
objTF.writeline strEmail
objDic.Add strEmail, ""
End If
End If
Next
objTF.Close
End Sub
回答by Dennis
export the file to C:\Users\Tony\Documents\sent file.CSV
将文件导出到 C:\Users\Tony\Documents\sent file.CSV
Then use ruby
然后使用红宝石
email_array = []
r = Regexp.new(/\b[a-zA-Z0-9._%+-]+@[a-zA-Z0-9.-]+\.[a-zA-Z]{2,4}\b/)
CSV.open('C:\Users\Tony\Documents\sent file.CSV', 'r') do |row|
email_array << row.to_s.scan(r)
end
puts email_array.flatten.uniq.inspect
回答by Bob Mortimer
Here's an updated version for those using Exchange. It converts Exchange format addresses to normal email addresses (with the @ symbol).
这是使用 Exchange 的用户的更新版本。它将 Exchange 格式的地址转换为普通的电子邮件地址（带有 @ 符号）。
' requires reference to Microsoft Scripting Runtime
Option Explicit
Sub Write_Out_Email_Addresses()
' dictionary for storing email addresses
Dim email_list As New Scripting.Dictionary
' file for output
Dim fso As New Scripting.FileSystemObject
Dim out_file As Scripting.TextStream
Set out_file = fso.CreateTextFile("C:\emails.csv", True)
' open the inbox
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Dim inbox As MAPIFolder
Set inbox = ns.GetDefaultFolder(olFolderInbox)
' loop through all items (some of which are not emails)
Dim outlook_item As Object
For Each outlook_item In inbox.Items
' only look at emails
If outlook_item.Class = olMail Then
' extract the email address
Dim email_address As String
email_address = GetSmtpAddress(outlook_item, ns)
' add new email addresses to the dictionary and write out
If Not email_list.Exists(email_address) Then
out_file.WriteLine email_address
email_list.Add email_address, ""
End If
End If
Next
out_file.Close
End Sub
' get email address form a Mailoutlook_item
' this entails converting exchange format addresses
' (like " /O=ROOT/OU=ADMIN GROUP/CN=RECIPIENTS/CN=FIRST.LAST")
' to proper email addresses
Function GetSmtpAddress(outlook_item As Outlook.MailItem, ns As Outlook.NameSpace) As String
Dim success As Boolean
success = False
' errors can happen if a user has subsequently been removed from Exchange
On Error GoTo err_handler
Dim email_address As String
email_address = outlook_item.SenderEmailAddress
' if it's an Exchange format address
If UCase(outlook_item.SenderEmailType) = "EX" Then
' create a recipient
Dim recip As Outlook.Recipient
Set recip = ns.CreateRecipient(outlook_item.SenderEmailAddress)
' extract the email address
Dim user As Outlook.ExchangeUser
Set user = recip.AddressEntry.GetExchangeUser()
email_address = user.PrimarySmtpAddress
email_address = user.Name + " <" + user.PrimarySmtpAddress + ">"
success = True
End If
err_handler:
GetSmtpAddress = email_address
End Function
Kudos to http://forums.codeguru.com/showthread.php?441008-Extract-sender-s-email-address-from-an-Exchange-emailand Brettdj
回答by Blake K Peterson
In outlook, export a folder to a csv file, then open in Excel. A simple MID function should be able to extract the email address if it's not been placed in a "from" column already.
在 Outlook 中，将文件夹导出为 csv 文件，然后在 Excel 中打开。如果电子邮件地址尚未放置在“发件人”列中，则简单的 MID 函数应该能够提取该电子邮件地址。
