Extract email addresses from Outlook using VBA

Sub ExtractEmail()
Dim Mailobject As Object
Dim olkRecipient As Outlook.Recipient
Dim Folder As MAPIFolder
Dim fs As Object
Dim a As Object
Dim mai As mailitem
    ' Display select folder dialog
    Set Folder = Session.PickFolder()
    ' Create Text File
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile("c:\deleteme\email addresses.txt", True)
    ' loop to read email address from mail items.
    For Each Mailobject In Folder.items
        If Mailobject.Class = olMail Then   ' typename(mailobject) = "MailItem"
            On Error GoTo assumeEncrypted
            If Mailobject.SenderEmailAddress <> "" Then
                If Mailobject.SenderEmailType = "EX" Then
                        a.WriteLine "Sender: " & GetSMTPAddress(Mailobject.SenderEmailAddress)
                Else
                        a.WriteLine "Sender: " & Mailobject.SenderEmailAddress
                End If
            End If
assumeEncrypted:
        End If
        For Each olkRecipient In Mailobject.Recipients
            If InStr(olkRecipient.Address, "@") > 0 Then
                a.WriteLine "    Recipient: " & olkRecipient.Address
            Else
                a.WriteLine "    Recipient: " & GetSMTPAddress(olkRecipient.Address)
            End If
        Next
    Next
    Set olkRecipient = Nothing
    Set Mailobject = Nothing
    a.Close
End Sub
Function GetSMTPAddress(ByVal strAddress As String)
' As supplied by Vikas Verma ... see
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim oCon As ContactItem
Dim strKey As String
Dim oRec As Recipient
Dim strRet As String
Dim fldr As MAPIFolder
    'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
    On Error Resume Next
    Set fldr = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).folders.Item("Random")
    If fldr Is Nothing Then
        Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).folders.Add "Random"
        Set fldr = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).folders.Item("Random")
    End If
    On Error GoTo 0
    If CInt(Left(Application.Version, 2)) >= 12 Then
        Set oRec = Session.CreateRecipient(strAddress)
        If oRec.Resolve Then
            strRet = oRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
        End If
    End If
    If Not strRet = "" Then GoTo ReturnValue
    'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
    'How it works
    '============
    '1) It will create a new contact item
    '2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
    '3) We will assign a random key to this contact item and save it in its Fullname to search it later
    '4) Next we will save it to local contacts folder
    '5) Outlook will try to resolve the email address & make AD call if required else take the Primary SMTP address from its cache and append it to Display name
    '6) The display name will be something like this " ( email.address@server.com )"
    '7) Now we need to parse the Display name and delete the contact from contacts folder
    '8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
    '9) We then need to delete it from Deleted Items folder as well, to clean all the traces
    Set oCon = fldr.items.Add(olContactItem)
    oCon.Email1Address = strAddress
    strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
    oCon.FullName = strKey
    oCon.Save
    strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
    oCon.Delete
    Set oCon = Nothing
    Set oCon = Session.GetDefaultFolder(olFolderDeletedItems).items.Find("[Subject]=" & strKey)
    If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
    GetSMTPAddress = strRet
End Function

                                              

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85: