Finne og hente ut mailadresser fra Outlook

 Tue 2013-10-22    Mail

Hvis man av en eller annen grunn skulle trenge å hente ut alle mailadresser fra alle mailer i alle mapper i Outlook, så finnes det selvsagt hjelp å få. En relativt enkel metode å gjøre det på, er via dette scriptet:

Sub EmailExport()
'Requires reference to Microsoft Scripting Runtime
'Tools –> References –> check "Microsoft Scripting Runtime"
Dim outApp As New Outlook.Application
Dim mpf As Outlook.MAPIFolder
Dim mpfSubFolder As Outlook.MAPIFolder
Dim mpfSubFolder1 As Outlook.MAPIFolder
Dim flds As Outlook.Folders
Dim flds1 As Outlook.Folders
Dim idx As Integer
Dim strEmail As String
Dim strEmails As String
Dim strCC As String
Dim strCCs As String
Dim dic As New Dictionary
Dim i As Integer
i = 1
Set mpf = Application.GetNamespace("Mapi").PickFolder
Set flds = mpf.Folders
Set mpfSubFolder = flds.GetFirst
Do While Not mpfSubFolder Is Nothing
Debug.Print i & " - " & mpfSubFolder; ""
For Each objItem In mpfSubFolder.Items
If objItem.Class = olMail Then
strEmail = objItem.SenderEmailAddress
strCC = objItem.CC
If Not dic.Exists(strEmail) Then
strEmails = strEmails + strEmail + vbCrLf
strCCs = strCCs + strCC + vbCrLf
End If
End If
Next
Set flds1 = mpfSubFolder.Folders
Set mpfSubFolder1 = flds1.GetFirst
Do While Not mpfSubFolder1 Is Nothing
Debug.Print i & " - " & mpfSubFolder1; ""
For Each objItem1 In mpfSubFolder1.Items
If objItem1.Class = olMail Then
strEmail = objItem1.SenderEmailAddress
strCC = objItem1.CC
If Not dic.Exists(strEmail) Then
strEmails = strEmails + strEmail + vbCrLf
strCCs = strCCs + strCC + ";"""
End If
End If
Next
Set mpfSubFolder1 = flds1.GetNext
i = i + 1
Loop
Set mpfSubFolder = flds.GetNext
i = i + 1
Loop
writeText = SaveTextToFile("C:\temp\mailadresser.txt", strEmails, True)
writeText = SaveTextToFile("C:\temp\mailadresserCC.txt", strCCs, True)
dic.Add strEmail, """"
End Sub
'this is verbatim from http://www.freevbcode.com/ShowCode.Asp, it saves the files to a text file
Public Function SaveTextToFile(FileFullPath As String, sText As String, Optional Overwrite As Boolean = False) As Boolean
'Purpose: Save Text to a file
'Parameters:
'– FileFullPath – Directory/FileName to save file to
'– sText – Text to write to file
'– Overwrite (optional): If true, if the file exists, it
'is overwritten. If false,
'contents are appended to file
'if the file exists
'Returns: True if successful, false otherwise
'Example:
'SaveTextToFile "C:\My Documents\MyFile.txt", "Hello There"
On Error GoTo ErrorHandler
Dim iFileNumber As Integer
iFileNumber = FreeFile
If Overwrite Then
Open FileFullPath For Output As #iFileNumber
Else
Open FileFullPath For Append As #iFileNumber
End If
Print #iFileNumber, sText
SaveTextToFile = True
ErrorHandler:
Close #iFileNumber
End Function