Announcement

Collapse
No announcement yet.

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="[email protected]"][email protected][/EMAIL]
     ' [URL]http://www.AnAmericanCares.com[/URL] 
     ' [URL]http://www.SwedesDock.com[/URL]
     
     
     
     
     
     #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="[email protected]"][email protected][/EMAIL] " In fil$
        Replace "[email protected]," With "[EMAIL="[email protected]"][email protected][/EMAIL]," In fil$
        Replace "[email protected]" With "[EMAIL="[email protected]"][email protected][/EMAIL]" In fil$
        Replace "[email protected]" With "[EMAIL="[email protected]"][email protected][/EMAIL] " In fil$
        Replace "[email protected]" With "[EMAIL="[email protected]"][email protected][/EMAIL]" In fil$
        Replace "[EMAIL="[email protected]"][email protected][/EMAIL]." With "[EMAIL="[email protected]"][email protected][/EMAIL] " In fil$
        Replace "[EMAIL="[email protected]"][email protected][/EMAIL]." With "[EMAIL="[email protected]"][email protected][/EMAIL] " 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="[email protected]"][email protected][/EMAIL]": m_Iterate_Loop 
           l$ = "[EMAIL="[email protected]"][email protected][/EMAIL]": 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="[email protected]"][email protected][/EMAIL]": m_Iterate_Loop 
           l$ = "[EMAIL="[email protected]"][email protected][/EMAIL]": m_Iterate_Loop 
           l$ = "[EMAIL="[email protected]"][email protected][/EMAIL]": m_Iterate_Loop 
           l$ = "[EMAIL="[email protected]"][email protected][/EMAIL]": m_Iterate_Loop 
           l$ = "[EMAIL="[email protected]"][email protected][/EMAIL]": m_Iterate_Loop 
           l$ = "[EMAIL="[email protected]et.Mx"][email protected][/EMAIL]": m_Iterate_Loop 
           l$ = "[EMAIL="[email protected]"][email protected][/EMAIL]": m_Iterate_Loop 
           l$ = "[EMAIL="[email protected]"][email protected][/EMAIL]": 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/

  • #2
    Why not in Source Code code Forum> ?

    Where would you look for Source Code to extract addresses from Eudora address book?

    Me, I'd search subject Eudora, forum source code, all dates.

    MCM
    Michael Mattias
    Tal Systems (retired)
    Port Washington WI USA
    [email protected]
    http://www.talsystems.com

    Comment


    • #3
      Originally posted by Michael Mattias View Post
      Why not in Source Code code Forum> ?

      Where would you look for Source Code to extract addresses from Eudora address book?

      Me, I'd search subject Eudora, forum source code, all dates.

      MCM
      As always, a good point. I'll repost it there.

      ===============================
      "Money doesn't make you happy.
      I now have $50 million but I was just as happy
      when I had $48 million."
      Arnold Schwarzenegger
      ===============================
      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/

      Comment

      Working...
      X