Tweet
I just had occasion to extract the addys from Eudora's address book.
Here's the code for whatevervalue any may find:
'
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]"][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 '
Why not in Source Code code Forum> ?
Comment