mailsndasync1.pas

BaiduMp3 search baidu mp3

        Obj.RcptName         := Trim(ToEdit.Text);
        Obj.HdrTo            := Trim(ToEdit.Text);
        Obj.HdrSubject       := Trim(SubjectEdit.Text);
        Obj.MailMessage      := Trim(MessageEdit.Text);
        Queue.Add(Obj);
    end;
    StartSendButton.Enabled := (Queue.Count > 0) and (Pool.Count = 0);
    Label10.Caption := IntToStr(Queue.Count) + ' Jobs in Queue';
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.StartSendbuttonClick(Sender: TObject);
begin
    FAbort := FALSE;
    StartSendButton.Enabled := (Queue.Count > 0) and (Pool.Count = 0);
    if Queue.Count < 1 then
        raise Exception.Create('Queue is empty!');
    MaxConnections := StrToInt(Trim(MaxConEdit.Text));

    { Usually an internal DNS lookup is done by the TSmtpCli component.      }
    { But the OS serializes name resolution, this compromize the parallel    }
    { operation. Anyway, a single name resolution is enough for all requests }
    { to the same server. We use TWSocket for the DNS Lookup here.           }
    if not WSocket.WSocketIsDottedIP(Trim(HostEdit.Text)) then begin
        Display('Resolving host name...');
        WSocket1.DnsLookup(Trim(HostEdit.Text));
    end
    else begin
        FHostIP := Trim(HostEdit.Text);
        { Feed the 'pool' }
        while (Pool.Count < MaxConnections) and (Queue.Count > 0) and (not FAbort) do
            AddToPool(PMailData(Queue.Items[0]));
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.ClearMemoButtonClick(Sender: TObject);
begin
    DisplayMemo.Clear;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.AbortButtonClick(Sender: TObject);
var
   I: Integer;
begin
   FAbort := TRUE;
   for I := 0 to Pool.Count -1 do
       PObj(Pool.Items[I]).SmtpClient.Abort;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.WSocket1DnsLookupDone(Sender: TObject; ErrCode: Word);
begin
    if ErrCode <> 0 then
        Display('DNS lookup failed. Error #'+IntToStr(ErrCode) + ' - '
               + WSocket.WSocketErrorDesc(ErrCode))
    else begin
        FHostIP := WSocket1.DnsResult;
        Display('Host name resolved to: ' + FHostIP);

        { Feed the 'pool' }
        while (Pool.Count < MaxConnections) and (Queue.Count > 0) and (not FAbort) do
            AddToPool(PMailData(Queue.Items[0]));
    end;
end;



{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.AddToPool(MailData: PMailData);
var
    Obj  : PObj;
    I, J : Integer;
begin
    if not Assigned(MailData) then
        Exit;
    New(Obj);
    Obj.SmtpClient                    := TSmtpCli.Create(nil);
    Obj.SmtpClient.OnRequestDone      := SmtpRequestDone;
    Obj.SmtpClient.OnSessionClosed    := SmtpSessionClosed;
    Obj.SmtpClient.OnSessionConnected := SmtpSessionConnected;
    Obj.SmtpClient.OnResponse         := SmtpResponse;
    Obj.SmtpClient.OnCommand          := SmtpCommand;
    Obj.SmtpClient.Host               := FHostIP;
    Obj.SmtpClient.SignOn             := ('ICS');
    Obj.SmtpClient.FromName           := Trim(FromEdit.Text);
    Obj.SmtpClient.HdrFrom            := Trim(FromEdit.Text);
    Obj.SmtpClient.Username           := Trim(UserEdit.Text);
    Obj.SmtpClient.Password           := Trim(PasswordEdit.Text);
    Obj.SmtpClient.RcptName.Add(MailData^.RcptName);
    Obj.SmtpClient.HdrTo              := MailData^.HdrTo;
    Obj.SmtpClient.HdrSubject         := MailData^.HdrSubject;
    Obj.SmtpClient.MailMessage.Text   := MailData^.MailMessage;
    if CheckBoxAuth.Checked then
        Obj.SmtpClient.AuthType := smtpAuthAutoSelect;

    Obj.LogList                       := TStringList.Create;
    I := Pool.Add(Obj);
    J := Queue.IndexOf(MailData);
    Dispose(PObj(Queue.Items[J]));
    Queue.Delete(J);

    if FCount = MaxInt then
        FCount := 0;
    Inc(FCount);

    Label10.Caption := IntToStr(Queue.Count) + ' Jobs in Queue';
    LogLine(PObj(Pool.Items[I]).SmtpClient, '');
    LogLine(PObj(Pool.Items[I]).SmtpClient, '+++++++++++++++++++++++++++++++++++++++++++++++++++');
    LogLine(PObj(Pool.Items[I]).SmtpClient, '                      '+   IntToStr(FCount));
    LogLine(PObj(Pool.Items[I]).SmtpClient, '+++++++++++++++++++++++++++++++++++++++++++++++++++');

    PObj(Pool.Items[I]).SmtpClient.Open; //----->
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.SmtpRequestDone(Sender: TObject; RqType: TSmtpRequest;
    ErrorCode: Word);
var
    ErrMsg     : String;
    SmtpClient : TSmtpCli;
begin
    { All requests from all instances of TSmtpCli return here. }
    { Sender is a pointer to current TSmtpCli instance.        }
    SmtpClient := (Sender as TSmtpCli);
    if ErrorCode = 0 then begin
        case RqType of
            smtpOpen : SmtpClient.Mail;
            smtpMail : SmtpClient.Quit;
            { We cannot free an instance of TSmtpCli in one of its event handlers. }
            { So we post a custom message, the object will be freed delayed in     }
            { proc WMRemoveObj.                                                    }
            smtpQuit : PostMessage(Form1.Handle, WM_REMOVEOBJ, Integer(Sender), 0);
        else
            { Should not happen }
            SmtpClient.Abort;
            LogLine(Sender, 'Unknown request type, session aborted');
            PostMessage(Form1.Handle, WM_REMOVEOBJ, Integer(Sender), 0);
        end;
    end
    else begin
        if ErrorCode < 10000 then
            ErrMsg := SmtpClient.ErrorMessage
        else
            ErrMsg := 'RqType:' + IntToStr(Ord(RqType)) + ' ErrorCode:'
                     + IntToStr(ErrorCode);
        if ErrMsg = '' then
            ErrMsg := 'Unknown error';
        LogLine(Sender, ErrMsg);
        SmtpClient.Abort;
        PostMessage(Form1.Handle, WM_REMOVEOBJ, Integer(Sender), 0);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.WMRemoveObj(var Msg: TMessage);
var
    I          : Integer;
    SmtpClient : TSmtpCli;
    Obj        : PObj;
begin
    { Reusing the object would be more effective. }
    SmtpClient := TSmtpCli(Msg.WParam);
    I := FindObj(SmtpClient);
    if I > -1 then begin
        Obj := Pool.Items[I];
        if CheckBoxDisplay.Checked then begin
            DisplayMemo.Lines.AddStrings(Obj.LogList);
            RefreshDisplay;
        end;
        { clean up }
        Obj.LogList.Free;
        Obj.LogList := nil;
        Obj.SmtpClient.Free;
        Obj.SmtpClient := nil;
        Dispose(Obj);
        Pool.Delete(I);
    end;

    if (Pool.Count < MaxConnections) and (Queue.Count > 0) and (not FAbort)then
        AddToPool(PMailData(Queue.Items[0]));

    StartSendButton.Enabled := (Queue.Count > 0) and (Pool.Count = 0);
    if StartSendButton.Enabled then begin
        Label10.Caption := IntToStr(Queue.Count) + ' Jobs in Queue';
        Beep;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.SmtpSessionConnected(Sender: TObject; ErrCode: Word);
begin
    LogLine(Sender, '>SMTP session connected, error #' +IntToStr(ErrCode));
end;



{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.SmtpSessionClosed(Sender: TObject; ErrCode: Word);
begin
    LogLine(Sender, '>SMTP session closed, error #' +IntToStr(ErrCode));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.SmtpCommand(Sender: TObject; Msg: String);
begin
    LogLine(Sender, '>' + Msg);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.SmtpResponse(Sender: TObject; Msg: String);
begin
    LogLine(Sender, '<' + Msg);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TForm1.FindObj(SmtpClient: TSmtpCli) : Integer;
var
    I: Integer;
begin
    Result := -1;
    for I := 0 to Pool.Count - 1 do begin
        if SmtpClient = PObj(Pool.Items[I]).SmtpClient then begin
            Result := I;
            Exit;
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.LogLine(Sender: TObject; Msg: String);
var
    I   : Integer;
    Obj : PObj;
begin
    if not CheckBoxDisplay.Checked then
        Exit;
    I := FindObj(Sender as TSmtpCli);
    if I > -1 then begin
        Obj  := Pool.Items[I];
        Obj.LogList.Add('ID #' + IntToStr(Integer(Sender as TSmtpCli)) + ' ' + Msg);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.Display(const Msg : String);
begin
    if not CheckBoxDisplay.Checked then
        Exit;
    DisplayMemo.Lines.BeginUpdate;
    try
        if DisplayMemo.Lines.Count > 200 then begin
            { We preserve only 200 lines }
            while DisplayMemo.Lines.Count > 200 do
                DisplayMemo.Lines.Delete(0);
        end;
        DisplayMemo.Lines.Add(Msg);
    finally
        DisplayMemo.Lines.EndUpdate;
        { Makes last line visible }
        {$IFNDEF VER80}
        SendMessage(DisplayMemo.Handle, EM_SCROLLCARET, 0, 0);
        {$ENDIF}
    end;
end;



{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TForm1.RefreshDisplay;
begin
    DisplayMemo.Lines.BeginUpdate;
    try
        if DisplayMemo.Lines.Count > 200 then begin
            { We preserve only 200 lines }
            while DisplayMemo.Lines.Count > 200 do
                DisplayMemo.Lines.Delete(0);
        end;
    finally
        DisplayMemo.Lines.EndUpdate;
        { Makes last line visible }
        {$IFNDEF VER80}
        SendMessage(DisplayMemo.Handle, EM_SCROLLCARET, 0, 0);
        {$ENDIF}
    end;
end;


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



end.