Чтение email адресов из Outlook .dbx файлов

Previous  Top  Next

    
 

 

 

Code:

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.

 

 

©Drkb::04446

Взято с сайта http://www.swissdelphicenter.ch/en/tipsindex.php