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