whats new ¦  programming tips ¦  indy articles ¦  intraweb articles ¦  informations ¦  links ¦  interviews
 misc ¦  tutorials ¦  Add&Win Game

Tips (1548)

Database (90)
Files (137)
Forms (107)
Graphic (116)
IDE (21)
Indy (5)
Internet / LAN (131)
IntraWeb (0)
Math (76)
Misc (127)
Multimedia (45)
Objects/
ActiveX (51)

OpenTools API (3)
Printing (35)
Strings (83)
System (268)
VCL (243)

Top15

Tips sort by
component


Search Tip

Add new Tip

Add&Win Game

Advertising

18 Visitors Online


 
...extract email addresses from Outlook .dbx files?
Autor: SennaSpy
[ Print tip ]  

Tip Rating (7):  
     


unit ExtractEmailsFunc;

interface

uses
  
Windows, SysUtils;

procedure CheckEMail(FilePath: string);

implementation

var
  
BufferSize: Integer;

function VerifyFile(strFileName: string): Integer;
var
  
intErro: Integer;
  tsrFile: TSearchRec;
begin
  
intErro := FindFirst(strFileName, FaAnyFile, tsrFile);
  if intErro = 0 then Result := tsrFile.Size 
  else 
    
Result := -1;
  FindClose(tsrFile);
end;

procedure CheckEMail(FilePath: string);
var
  
I: Integer;
  hFile: Integer;
  Buffer: PChar;
  StrEmail: string;
begin
  
hFile := FileOpen(FilePath, fmOpenRead);
  try
    if 
hFile = 0 then Exit;
    GetMem(Buffer, bufferSize + 1);
    ZeroMemory(Buffer, BufferSize + 1);
    try
      
FileRead(hFile, Buffer^, BufferSize);
      I := 0;
      while I <= BufferSize - 1 do 
      begin
        
StrEmail := '';
        if Buffer[I] = '<' then 
        begin
          
Inc(I);
          while (Buffer[I] <> '@') and (I <= BufferSize) do 
          begin
            if 
(Buffer[I] = CHR(45)) or (Buffer[I] = CHR(46)) or
              
(Buffer[I] = CHR(90)) or ((Buffer[I] > CHR(49)) and (Buffer[I] <= CHR(57)))
              or ((Buffer[I] >= CHR(65)) and (Buffer[I] <= CHR(90))) or
              
((Buffer[I] >= CHR(97)) and (Buffer[I] <= CHR(122))) then 
            begin
              
StrEmail := StrEmail + Buffer[I];
            end 
            else 
            begin
              
StrEmail := '';
              Break;
            end;
            Inc(I);
          end;
          if StrEmail <> '' then 
          begin
            
StrEmail := StrEmail + '@';
            Inc(I);
            while (Buffer[I] <> '.') and (I <= BufferSize) do 
            begin
              if 
(Buffer[I] = CHR(45)) or (Buffer[I] = CHR(46)) or
                
(Buffer[I] = CHR(90)) or ((Buffer[I] >= CHR(49)) and (Buffer[I] <= CHR(57)))
                or ((Buffer[I] >= CHR(65)) and (Buffer[I] <= CHR(90))) or
                
((Buffer[I] >= CHR(97)) and (Buffer[I] <= CHR(122))) then 
              begin
                
StrEmail := StrEmail + Buffer[I];
              end 
              else 
              begin
                
StrEmail := '';
                Break;
              end;
              Inc(I);
            end;
            if StrEmail <> '' then 
            begin
              
StrEmail := StrEmail + '.';
              Inc(i);
              while (Buffer[I] <> '>') and (I <= BufferSize) do 
              begin
                if 
(Buffer[I] = CHR(45)) or (Buffer[I] = CHR(46)) or
                  
(Buffer[I] = CHR(90)) or ((Buffer[I] >= CHR(49)) and (Buffer[I] <= CHR(57)))
                  or ((Buffer[I] >= CHR(65)) and (Buffer[I] <= CHR(90))) or
                  
((Buffer[I] >= CHR(97)) and (Buffer[I] <= CHR(122))) then 
                begin
                  
StrEmail := StrEmail + Buffer[I];
                end 
                else 
                begin
                  
StrEmail := '';
                  Break;
                end;
                Inc(I);
              end;
              if StrEmail <> '' then 
              begin
                
WriteLn(StrEmail);
                Inc(I);
              end;
            end;
          end;
        end 
        else 
          
Inc(I);
      end;
    finally
      
FreeMem(Buffer);
    end;
  finally
    
FileClose(hFile);
  end;
end;

begin
  
BufferSize := VerifyFile(ParamStr(1));
  if BufferSize <= 0 then Exit;
  CheckEMail(ParamStr(1));
end.

 

Rate this tip:

poor
very good


Copyright © by SwissDelphiCenter.ch
All trademarks are the sole property of their respective owners