Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Extract email addresses from Eudora's Address Book

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Extract email addresses from Eudora's Address Book

    I just had occasion to extract the addys from Eudora's address book.

    Here's the code for whatevervalue any may find:

    '
    Code:
     ' Extracts email addresses from Eudora's Address book
     ' To run you must:
     '  1) Change the folder in 'Sub Extract_Email_addresses_from_Eudora
     '     to where "NNdbase.txt" is located on your computer
     '  2) Change the folder for "c:\Temp\Unique_Email_Addresses.txt"
     '     from "C:\Temp\" to whatever you use
     '
     ' What I did was run the program then look at the Unique file
     '  in a text editor, note the errors then make changes to the
     '  Replace statements and the "Skips" list as appropriate for the list.
     '
     '
     '
     '  It will probably take several runs before the Unique file is okay.
     '
     ' For the record I had 4,538 useable addresses out of 9,706 total in
     '  the address book.
     '
     ' [email protected]
     ' http://www.AnAmericanCares.com
     ' http://www.SwedesDock.com
     
     
     
     
     
     #Compile Exe
     #Dim All
     '
     #Include "WIN32API.INC"
     '
     %Sample_TB = 1000
     '
     'email addys
     Type Addy
       Sort_Field As String * 50
       Nam As String * 50
       Domain As String * 50
       Flag As Long
       Dup_flag As Long
     End Type
       Global Addys() As Addy
       Global addys1() As Addy
     
     '
     Macro Common_Locals
       'note - not all these used in Sample
       Local Ans&, a$, a1$, Array_End&
       Local Box_Height&, Btn_Width&, Btn_Height&
       Local Caption$, col&, Code$, ctr&, ctr1&, ctr2&, ctr3&
       Local Domain$
       Local email$, ep&, er$ 'used for error msgs
       Local Fil$, Fil1$, Flag&, flen&, fnum&, fnum1&, fnum2&
         Local Files$()
       Local hght&
       Local i&, i1&, i2&, i3&, id&
       Local l$, l1&, Lng&, lng1&, ln$()
       Local m$, m1$
       Local n&, num&, num1&
       Local r&, Row&, Row1&
       Local shrt&, sp&, Spcr&
       Local Tb_Height&
       Local Wdth&
       Local x&, x1&
     
     
     
       Dim Files$(0)
       Box_Height = 12
       Tb_Height  = 12
     
       %Top = %MB_TASKMODAL 'I can never remember %MB_TASKMODAL for MB's  
     
     'Common RGB Colors from Win32Api.Inc
       %Black   = &H000000???
       %Blue    = &HFF0000???
       %Green   = &H00FF00???
       %Cyan    = &HFFFF00???
       %Red     = &H0000FF???
       %Magenta = &HFF00FF???
       %Yellow  = &H00FFFF???
       %White   = &HFFFFFF???
       %Gray    = &H808080???
       %LtGray  = &HC0C0C0???
       %Purple = &hFF5588
       %BabyBlue = 167 + (241 * 256) + (252 * 256 * 256)
       %Pink     = 255 + (132 * 256) + (132 * 256 * 256)
       %Cream    = 252 + (241 * 256) + (167 * 256 * 256)
       %BiliousYG = %Cream + 1000 ' Bilious Yellow Green
       %MintGreen = &HD0FFD0
     
     End Macro
     '
     '
     Macro Err_Msg
      'er$ set by programmer
      If Err Then
        ? Using$("# ", Err) & Error$(Err) &  $CrLf &_
          er$,, FuncName$
         Reset er$ 'for next time
      End If
     End Macro
     '
     
     '
     Macro mb_ans = Ans = MsgBox(m$, %MB_TASKMODAL Or %MB_YESNO, " in " & FuncName$ & m1$ )
     ' example usage
     '  m$ = "Do you REALLY want to erase everything?"
     '  mb_ans
     '  If ans = %IdYes Then
     '    '
     '  End If
     '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
     
     '
     Macro mb = ? m$, %Top, FuncName$
     '
     
     '
     Macro pf = Print #Fnum,
     '
     Macro m_Sort_by_Domain
        For x = LBound(Addys()) To UBound(addys())
           addys(x).Sort_Field = addys(x).Domain
        Next x
        Array Sort addys()
     End Macro
     '
     Macro m_Sort_by_Name
        For x = LBound(Addys()) To UBound(addys())
           addys(x).Sort_Field = addys(x).Nam
        Next x
        Array Sort addys()
     End Macro
     '
     Macro m_Iterate_Loop = If InStr(LCase$(m$), LCase$(l$)) Then Iterate Loop
     '
     
     
     '
     Sub Extract_Email_addresses_from_Eudora
        Common_Locals
     
         'Change to appropriate folder
       Fil$ = "C:\Program Files\Eudora\NNdbase.txt" 'addresses
       Fnum = FreeFile
       Open fil$ For Binary As #fnum
        flen = Lof(fnum)
       fil$ = String$(flen, 32)
       Get fnum, 1, fil$
       Close
     
        'clean up file
        Replace "<" With " " In fil$
        Replace ">" With " " In fil$
        Replace "@ " With "@" In fil$
        Replace ".com." With ".com " In fil$
        Replace ".ne " With ".net " In fil$
        Replace ".Ne " With ".Net " In fil$
        Replace "[email protected]" With "[email protected] " In fil$
        Replace "[email protected]," With "[email protected]," In fil$
        Replace "[email protected]" With "[email protected]" In fil$
        Replace "[email protected]" With "[email protected] " In fil$
        Replace "[email protected]" With "[email protected]" In fil$
        Replace "[email protected]." With "[email protected] " In fil$
        Replace "[email protected]." With "[email protected] " In fil$
     '   Replace "@ " With "@" In fil$
     '   Replace "@ " With "@" In fil$
     '   Replace "@ " With "@" In fil$
     '   Replace "@ " With "@" In fil$
     '   Replace "@ " With "@" In fil$
     '   Replace "@ " With "@" In fil$
        Replace "," With " " In fil$
        Replace  $CrLf With "  " In fil$
     
        Fil$ = " " & fil$ & " " 'pad it out to find 1st & last addys
        ctr1 = ParseCount(fil$, "@")
     
     
        i = 1
        shrt = 1000
       While i
        i = InStr(Fil$, "@") 'find addy
         If i Then
           i2 = InStr(i, fil$, " ") 'find end of addy
            m$ = Left$(Fil$, i2 - 1) 'isolate it
     
           Fil$ = Trim$(Mid$(Fil$, i2))' strip from file
     
           i3 = InStr(-1, m$, " ")'find beginning of addy
           m$ = Mid$(m$, i3 + 1 )'pick it out
     
             'skips
           l$ = "Senate.Gov": m_Iterate_Loop 'no senators this run
     
           l$ = "reply": m_Iterate_Loop
           l$ = "confirm": m_Iterate_Loop
           l$ = "ladies.only": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "Dxoburch": m_Iterate_Loop
           l$ = "Fzbigarrett": m_Iterate_Loop
           l$ = "Announce": m_Iterate_Loop
           l$ = ".Info": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "Notification": m_Iterate_Loop
           l$ = "Oprah.Com": m_Iterate_Loop
           l$ = "Pondersbible": m_Iterate_Loop
           l$ = "Powerbasicprg": m_Iterate_Loop
           l$ = "Puritans_Pride": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           l$ = "[email protected]": m_Iterate_Loop
           'l$ = "Fzbigarrett": m_Iterate_Loop
           'l$ = "Fzbigarrett": m_Iterate_Loop
           'l$ = "Fzbigarrett": m_Iterate_Loop
           'l$ = "Fzbigarrett": m_Iterate_Loop
           'l$ = "Fzbigarrett": m_Iterate_Loop
           'l$ = "Fzbigarrett": m_Iterate_Loop
           'l$ = "Fzbigarrett": m_Iterate_Loop
     
     
     
            l1 = Len(m$) 'find longest addy for Type Setting
            If l1 > lng Then
               lng = L1
            End If
     
            If l1 < shrt Then
               shrt  = L1
            End If
     
            If shrt < 10 Then 'too short I think for good addy
               shrt = 1000
               Iterate Loop 'start looking again
            End If
     
           Incr ctr
           ReDim Preserve Addys(1 To ctr)
           Addys(UBound(Addys())).Nam = MCase$(m$)
           i =InStr(m$, "@") 'find domain
            If i Then
              m$ = LCase$(Mid$(m$, i + 1))
              If Trim$(m$) = "aol" Then m$ = "Aol.com" 'fix truncated addresses
              Addys(UBound(Addys())).Domain = MCase$(m$)
            End If
         End If 'end of: i = InStr(Fil$, "@") 'find addy
        Wend
     
        m_Sort_by_Name
     '   m_Sort_by_Domain   'used to find corrupted domains
     
      'find dups
        Array_End = UBound(addys())
        For x = LBound(Addys()) To UBound(addys())
           If x < UBound(Addys()) Then
              If addys(x).Nam = addys(x + 1).Nam Then
                 addys(x).Dup_Flag = 1
              End If
           End If
         Next x
     
     
        'print uniques
        Open "c:\Temp\Unique_Email_Addresses.txt" For Output As #fnum
     
        Reset ctr
        For x = LBound(Addys()) To UBound(addys())
           ctr = ctr + addys(x).Dup_Flag
            If addys(x).Dup_Flag = 0 Then
              pf addys(x).Nam
              If Left$(addys(x).Domain, 3) ="Aol" Then Incr ctr3 'count aol's
            End If
        Next x
     
       m$ = $CrLf & Using$("#, addys total  #, dups  #, good", ctr1, ctr, ctr1-ctr) & $CrLf  & _
            Using$("  # Aols every # emails", _
                    ctr3, ctr \ ctr3)
       mb
       pf  $CrLf  &  $CrLf  & m$
       Close
     
     '  Call Create_Email_List(Ctr, ctr3)
     '
     End Sub
     '
     Sub Testing
     End Sub
     CallBack Function CB_Main_Dialog As Long
     End Function
     '
     Function PBMain
       Local hDlg As Dword
       Dialog New 0, "Sample Example",,, 100, 200,, To hDlg
        Call Extract_Email_addresses_from_Eudora
     '  Dialog Show Modal hDlg, Call CB_Main_Dialog
     
     End Function
     '
    It's a pretty day. I hope you enjoy it.

    Gösta

    JWAM: (Quit Smoking): http://www.SwedesDock.com/smoking
    LDN - A Miracle Drug: http://www.SwedesDock.com/LDN/
Working...
X