| Код | 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. |
--------------------
Если хочешь, что бы что-то работало - используй написанное,
если хочешь что-то понять - пиши сам... |
Чтение email адресов из Outlook .dbx файлов 
Загрузка ...
