mailrob1.pas

互联网套件

begin
    while FNames.Count > 0 do begin
        FreeMem(FNames.Items[0], StrLen(PChar(FNames.Items[0])) + 1);
        FNames.Delete(0);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function StringCompare(Item1, Item2: Pointer): Integer;
begin
    Result := StrComp(PChar(Item1), PChar(Item2));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.ProcessMsg;
var
    Line     : String;
    I        : Integer;
    EMail    : String;
    p        : PChar;
    MsgCount : Integer;
    OkCount  : Integer;
begin
    DisplayMemo.Lines.Add('Clear list');
    ClearNames;

    DisplayMemo.Lines.Add('Reading EMail');
    MsgCount := 0;
    OkCount  := 0;
    while not MbxHandler.Eof do begin
        Inc(MsgCount);
        FMsgLines.LoadFromStream(MbxHandler.MsgStream);
        I := SearchHeader('SUBJECT');
        if I < 0 then
            DisplayMemo.Lines.Add('Subject not found')
        else begin
            Line := FMsgLines.Strings[I];

            if Copy(Line, 10, 9) = 'SUBSCRIBE' then begin
                I := Length(Line);
                while (I > 0) and (Line[I] <> ' ') do
                    Dec(I);
                EMail := Copy(Line, I + 1, 255);
                GetMem(p, Length(EMail) + 1);
                Move(EMail[1], p^, Length(EMail));
                FNames.Add(p);
                Inc(OkCount);
            end;
        end;
        MbxHandler.Next;
        InfoLabel.Caption := Format('%d/%d/%d', [MsgCount, OkCount, MbxHandler.MsgCount]);
        Application.ProcessMessages;
    end;

{$IFNDEF VER80}  { Delphi 1 does'nt support sorting TList items }
    DisplayMemo.Lines.Add('Sort list');
    FNames.Sort(StringCompare);
{$ENDIF}

    DisplayMemo.Lines.Add('Remove duplicates');
    Line := '';
    p    := @Line[1];
    I    := 0;
    while I < FNames.Count do begin
        if StringCompare(p, FNames.Items[I]) = 0 then begin
            FreeMem(FNames.Items[I], StrLen(PChar(FNames.Items[I])) + 1);
            FNames.Delete(I);
        end
        else begin
            p := FNames.Items[I];
            Inc(I);
        end;
    end;

    DisplayMemo.Lines.Add('Display list');
    for I := 0 to FNames.Count - 1 do
        DisplayMemo.Lines.Add(StrPas(PChar(FNames.Items[I])));

    DisplayMemo.Lines.Add('Total : ' + IntToStr(FNames.Count));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.SendButtonClick(Sender: TObject);
var
    EMail    : String;
    I        : Integer;
    OkCount  : Integer;
    BadCount : Integer;
    Success  : Boolean;
begin
    if FRunning then begin
        FRunning := FALSE;
        Exit;
    end;
    FRunning := TRUE;
    DisplayMemo.Lines.Add('Sending EMails');
    if FNames.Count <= 0 then begin
        Application.MessageBox('List is empty', 'Warning', MB_OK);
        Exit;
    end;

    OkCount  := 0;
    BadCount := 0;
    try
        SmtpClient.SignOn          := SignOnEdit.Text;
        SmtpClient.Host            := HostEdit.Text;
        SmtpClient.Port            := PortEdit.Text;
        Success := SmtpClient.OpenSync;
        if not Success then
            Exit;
        I := 0;
        while (not Application.Terminated) and (I < FNames.Count) do begin
            if not FRunning then begin
                Log('Canceled');
                CommitLog;
                DisplayMemo.Lines.Add('Canceled');
                Exit;
            end;
            EMail := StrPas(PChar(FNames.Items[I]));
            DisplayMemo.Lines.Add('Sending to ' + EMail);
            Log('Sending to ' + EMail);
            Success := FALSE;
            try
                SmtpClient.RcptName.Clear;
                SmtpClient.RcptName.Add(EMail);
                SmtpClient.HdrFrom         := FromEdit.Text;
                SmtpClient.HdrTo           := EMail;
                SmtpClient.HdrSubject      := SubjectEdit.Text;
                SmtpClient.FromName        := FromEdit.Text;
                SmtpClient.EmailFiles      := nil;
                Success                    := SmtpClient.MailSync;
            except
                on E:Exception do Log(E.Message);
            end;
            if Success then
                Inc(OkCount)
            else begin
                Inc(BadCount);
                Log('Can''t send to ' + EMail);
                DisplayMemo.Lines.Add('Can''t send to ' + EMail);
                { We failed, so disconnect before continuing }
                try
                    SmtpClient.Quit;
                except
                    on E:Exception do Log(E.Message);
                end;
                try
                    SmtpClient.Abort;
                except
                end;
                SmtpClient.SignOn          := SignOnEdit.Text;
                SmtpClient.Host            := HostEdit.Text;
                SmtpClient.Port            := PortEdit.Text;
                Success := SmtpClient.OpenSync;
                if not Success then
                    Exit;
            end;
            CommitLog;
            Inc(I);
            InfoLabel.Caption := Format('%d/%d/%d', [OkCount, BadCount, FNames.Count]);
        end;
    finally
        try
            SmtpClient.Quit;
        except
            on E:Exception do Log(E.Message);
        end;
        DisplayMemo.Lines.Add(IntToStr(OkCount) + ' emails sent succesfully');
        DisplayMemo.Lines.Add(IntToStr(BadCount) + ' failed');
        Log(IntToStr(OkCount) + ' emails sent succesfully');
        Log(IntToStr(BadCount) + ' failed');
        CloseLog;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.SmtpClientGetData(Sender: TObject; LineNum: Integer;
  MsgLine: PChar; MaxLen: Integer; var More: Boolean);
var
    Len : Integer;
begin
    if LineNum > EMailMemo.Lines.count then
        More := FALSE
    else begin
        Len := Length(EMailMemo.Lines[LineNum - 1]);
        { Truncate the line if too long (should wrap to next line) }
        if Len >= MaxLen then
            StrPCopy(MsgLine, Copy(EMailMemo.Lines[LineNum - 1], 1, MaxLen - 1))
        else
            StrPCopy(MsgLine, EMailMemo.Lines[LineNum - 1]);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.SaveToListButtonClick(Sender: TObject);
var
    Stream : TStream;
    I      : Integer;
begin
    DisplayMemo.Lines.Add('Saving to file');
    if FNames.Count <= 0 then begin
        Application.MessageBox('List is empty', 'Warning', MB_OK);
        Exit;
    end;

    Stream := TFileStream.Create(LstFileEdit.Text, fmCreate);
    try
        for I := 0 to FNames.Count - 1 do begin
            Stream.WriteBuffer(PChar(FNames.Items[I])^, StrLen(PChar(FNames.Items[I])));
            Stream.WriteBuffer(CrLf, 2);
        end;
        DisplayMemo.Lines.Add(IntToStr(FNames.Count) + ' EMails saved');
    finally
        Stream.Destroy;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.LoadFromListButtonClick(Sender: TObject);
var
    Stream   : TMemoryStream;
    I, J     : Integer;
    p, q     : PChar;
begin
    DisplayMemo.Lines.Add('Loading from file');
    ClearNames;
    Stream := TMemoryStream.Create;
    Stream.LoadFromFile(LstFileEdit.Text);
    p := Stream.Memory;
    I := 0;
    while I < Stream.Size do begin
        J := I;
        while (I < Stream.Size) and (p[i] <> #13) do
            Inc(I);
        if p[I] = #13 then
            Dec(I);
        GetMem(q, I - J + 2);
        Move(p[J], q^, I - J + 1);
        q[I - J + 1] := #0;
        FNames.Add(q);
        if DisplayMemo.Lines.Count > 200 then
            DisplayMemo.Clear;
        DisplayMemo.Lines.Add(StrPas(q));
        I := I + 3;
    end;
    Stream.Destroy;
    DisplayMemo.Lines.Add(IntToStr(FNames.Count) + ' EMails loaded');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.SmtpClientCommand(Sender: TObject; Msg: String);
begin
    { Memo boxes are not unlimited...}
    if DisplayMemo.Lines.Count > 200 then
        DisplayMemo.Clear;
    DisplayMemo.Lines.Add('    ' + Msg);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.SmtpClientResponse(Sender: TObject; Msg: String);
begin
    { Memo boxes are not unlimited...}
    if DisplayMemo.Lines.Count > 200 then
        DisplayMemo.Clear;
    DisplayMemo.Lines.Add('    ' + Msg);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.MsgFileLoadButtonClick(Sender: TObject);
begin
    LoadEMailMessage(MsgFileEdit.Text);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.SaveMsgFileButtonClick(Sender: TObject);
begin
    SaveEMailMessage(MsgFileEdit.Text);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.MbxFileEditDblClick(Sender: TObject);
begin
    OpenDialog1.DefaultExt := '.mbx';
    OpenDialog1.Filter     := 'Mail files (*.mbx)|*.MBX|All files (*.*)|*.*';
    OpenDialog1.Options    := [ofFileMustExist];
    OpenDialog1.Title      := 'MailRob - Open MBX file';
    OpenDialog1.InitialDir := ExtractFilePath(MbxFileEdit.Text);
    if OpenDialog1.Execute then
         MbxFileEdit.Text := OpenDialog1.FileName;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.MsgFileEditDblClick(Sender: TObject);
begin
    OpenDialog1.DefaultExt := '.txt';
    OpenDialog1.Filter     := 'Message files (*.txt)|*.TXT|All files (*.*)|*.*';
    OpenDialog1.Options    := [ofFileMustExist];
    OpenDialog1.Title      := 'MailRob - Open message file';
    OpenDialog1.InitialDir := ExtractFilePath(MsgFileEdit.Text);
    if OpenDialog1.Execute then
         MsgFileEdit.Text := OpenDialog1.FileName;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TMailRobForm.LstFileEditDblClick(Sender: TObject);
begin
    OpenDialog1.DefaultExt := '.txt';
    OpenDialog1.Filter     := 'AMail list files (*.txt)|*.TXT|All files (*.*)|*.*';
    OpenDialog1.Options    := [ofFileMustExist];
    OpenDialog1.Title      := 'MailRob - Open email list file';
    OpenDialog1.InitialDir := ExtractFilePath(LstFileEdit.Text);
    if OpenDialog1.Execute then
         LstFileEdit.Text := OpenDialog1.FileName;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.