Extraire les adresses email d'un fichier *.dbx d'outlook

unit ExtractEmailsFunc;

interface

uses
Windows, SysUtils;

procedure CheckEMail(FilePath: string);

implementation

var
BufferSize: Integer;

function Ver if yFile(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 := Ver if yFile(ParamStr(1));
if BufferSize <= 0 then Exit;
CheckEMail(ParamStr(1));
end.
Ajouter un commentaire
Pseudo
Adresse email
Site internet (optionnel)
Votre commentaire
Fiche de l'article
Mise a jour28/04/2009
VisualisationVu 2267 fois
PublicInternaute zz
CategorieDelphi - Trucs et astuces - Internet
Auteur de l'article
fobec fobec
connecté le 28/07/2016
41 ans - France Nord-Est
39 articles dans la section
Contacter l'auteur