'
' This will help create a whitelist for SpamPal, base on Outlook contacts.
'
' Code for the Outlook VBA macro ExportEmailAddressContacts().
' This macro will write the email addresses of all your Outlook contacts into a text file.
' It also adds your current user email address. All the entries are sorted alphabetically.
' You must first open the Outlook VBA project: open Outlook then click on "Tools" then "Macro" then "Visual Basic Editor".
' You then copy/paste the code below into a Outlook module's VBA project.
' You can change the text file name, which corresponds the the EXPORT_FILE constant.
' You then have to save the VBA project (click on "File" then "save VBAProject.OTM").
' To execute, return to Outlook then click on "Tools" then "Macro" then "Macros".
' A dialog box will appear, just select the "ExportEmailAddressContacts" macro and click on "Run".
' Works with Outlook 97, 2000, XP.
'
' To make SpamPal add the text file created to the White-lists, right-click on the pink umbrella, then select "Options".
' The "SpamPal Options" dialog box will appear. Click on the "Advanced" pane,
' then click on the "Extra Black- & White-lists" button.
' Another dialog box will appear. Click on the "Add" button.
' The Windows "Open File" dialog box will appear. Browse through it to select the text file created,
' then click on the "Open" button, then click on the "Close" button, then click on the "OK" button.
'
' Don't forget to run the macro regularly to keep contacts text file up to date!
'
' Jean-Francois BRIERE 2003
'

' Next line removed by JJF - some people were reporting it didn't work
' Probably due to differences between different versions of VBA
' Public Const EXPORT_FILE As String = "C:\My documents\outlook_contacts.txt"

Private Sub ConditionalAddEmail(emailStr, ByRef emailList)
    If Len(emailStr) > 0 Then
        If InStr(emailStr, "@") > 0 Then
            emailList.Add emailStr, emailStr
        End If
    End If
End Sub

Public Sub ExportEmailAddressContacts()
    Dim onMAPI As NameSpace
    Dim ofContacts As MAPIFolder
    Dim onUser As Recipient
    Dim emailList As New Collection
    
    Set onMAPI = GetNamespace("MAPI")
    Set ofContacts = onMAPI.GetDefaultFolder(olFolderContacts)
    Set ofContactsList = ofContacts.Items
    Set onUser = onMAPI.CurrentUser
    
    ConditionalAddEmail onUser.Address, emailList
    
    ' The next statement ignores the error caused
    On Error Resume Next
    For Each oiContact In ofContactsList
        If oiContact.Class = olContact Then
            ConditionalAddEmail oiContact.Email1Address, emailList
            ConditionalAddEmail oiContact.Email2Address, emailList
            ConditionalAddEmail oiContact.Email3Address, emailList
        End If
    Next
    ' Resume normal error handling
    On Error GoTo 0
    
    ' Sort the collection
    For i = 1 To emailList.Count - 1
        For j = i + 1 To emailList.Count
            If LCase(emailList(i)) > LCase(emailList(j)) Then
                Swap1 = emailList(i)
                Swap2 = emailList(j)
                emailList.Add Swap1, before:=j
                emailList.Add Swap2, before:=i
                emailList.Remove i + 1
                emailList.Remove j + 1
            End If
        Next j
    Next i
     
' Next line rewritten by JJF
'    Open EXPORT_FILE For Output As #1
    Open "C:\My documents\outlook_contacts.txt" For Output As #1
    For Each email In emailList
        Print #1, email
    Next
    Close #1
    
    Set emailList = Nothing
    
    MsgBox ("ExportEmailAddressContacts done!")
End Sub