...E-Mail Adressen von Outlook .dbx extrahieren?

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.

printed from
www.swissdelphicenter.ch
developers knowledge base