View Single Post
 
Old 09-09-2017, 01:33 PM
Luiz Eduardo Luiz Eduardo is offline
Member
 
Join Date: May 2014
Posts: 32
Question Why a queue Thread freeze the Form?

Hello,

i have this code below that send email to multiple recipients using a queue Thread, but while application is sending the Form stays freezed.

How solve?

Code:
unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Generics.Collections,
  SyncObjs, IdMessage,
  IdSMTP, IdText, IdBaseComponent, IdComponent, IdIOHandler, IdIOHandlerSocket,
  IdIOHandlerStack, IdSSL, IdSSLOpenSSL, IdGlobal, IdTCPConnection, IdTCPClient,
  IdExplicitTLSClientServerBase, IdMessageClient, IdSMTPBase;

Type
  TMyConsumerItem = class(TThread)
  private
    FQueue: TThreadedQueue;
    FSignal: TCountDownEvent;
  protected
    procedure Execute; override;
  public
    constructor Create(aQueue: TThreadedQueue; aSignal: TCountDownEvent);
  end;

type
  TForm1 = class(TForm)
    btn1: TButton;
    mmo1: TMemo;
    mmo2: TMemo;
    btn2: TButton;
    OpenDialog1: TOpenDialog;
    SSL1: TIdSSLIOHandlerSocketOpenSSL;
    idsmtp2: TIdSMTP;
    procedure btn1Click(Sender: TObject);
    procedure btn2Click(Sender: TObject);
  private
    { Private declarations }
    procedure DoSomeJob(myListItems: TStringList);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  IdSMTP: TIdSMTP;
  Email: TIdMessage;
  idtTextPart: TIdText;
  SSLHandler: TIdSSLIOHandlerSocketOpenSSL;

implementation

{$R *.dfm}

constructor TMyConsumerItem.Create(aQueue: TThreadedQueue;
  aSignal: TCountDownEvent);
begin
  Inherited Create(false);
  Self.FreeOnTerminate := true;
  FQueue := aQueue;
  FSignal := aSignal;
end;

procedure TMyConsumerItem.Execute;
var
  aProc: TProc;
begin
  try
    repeat
      FQueue.PopItem(aProc);
      if not Assigned(aProc) then
        break;
      aProc();
    until Terminated;
  finally
    FSignal.Signal;
  end;
end;

procedure TForm1.btn1Click(Sender: TObject);
var
  aList: TStringList;
  i: Integer;
begin
  mmo2.Clear;
  aList := TStringList.Create;
  try
    for i := 0 to mmo1.Lines.Count - 1 do
      aList.Add(mmo1.Lines.Strings[i]);
    DoSomeJob(aList);
  finally
    aList.Free;
  end;
end;

procedure TForm1.btn2Click(Sender: TObject);
begin
  if (OpenDialog1.Execute()) then
    mmo1.Lines.LoadFromFile(OpenDialog1.FileName);
end;

procedure TForm1.DoSomeJob(myListItems: TStringList);
const
  cThreadCount = 10;
  cMyQueueDepth = 100;
var
  i: Integer;
  s: string;
  aQueue: TThreadedQueue;
  aCounter: TCountDownEvent;

  function CaptureJob(const aString: string): TProc;
  begin
    s := '';
    Email.Clear;
    Email.From.Address := 'myuser@hotmail.com';
    Email.From.Name := 'myName';

    Email.Recipients.EmailAddresses := myListItems[i];
    Email.Subject := 'test message';
    Email.ContentType := 'multipart/related; type="multipart/alternative"';
    Email.CharSet := 'utf-8';

    idtTextPart := TIdText.Create(Email.MessageParts, nil);
    idtTextPart.ContentType := 'text/plain; charset=utf-8';
    idtTextPart.Body.Add('this is a test message');

    try
      if (not IdSMTP.Connected) then
      begin
        IdSMTP.Connect;
        IdSMTP.Authenticate;
      end;
    except
      on E: Exception do
      begin
        s := E.Message;
      end;
    end;

    try
      if IdSMTP.Connected then
      begin
        IdSMTP.Send(Email);
      end;
    except
      On E: Exception do
      begin
        s := E.Message;
      end;
    end;

    Result := procedure
      begin

        // Report status to main thread
        TThread.Synchronize(nil,
          procedure
          begin
            if s = '' then
              mmo2.Lines.Add(aString + ' success!');
            if s <> '' then
              mmo2.Lines.Add(aString + ' error: ' + s);
          end);

      end;
  end;

var
  aThread: TThread;
begin

  IdSMTP := TIdSMTP.Create(nil);
  SSLHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
  Email := TIdMessage.Create(nil);

  try

    SSLHandler.MaxLineAction := maException;
    SSLHandler.SSLOptions.Method := sslvSSLv23;
    SSLHandler.SSLOptions.Mode := sslmUnassigned;
    SSLHandler.SSLOptions.VerifyMode := [];
    SSLHandler.SSLOptions.VerifyDepth := 0;

    IdSMTP.IOHandler := SSLHandler;
    IdSMTP.Host := 'smtp.live.com';
    IdSMTP.Port := 587;
    IdSMTP.Username := 'myuser@hotmail.com';
    IdSMTP.Password := 'mypass';
    IdSMTP.UseTLS := utUseExplicitTLS;

    aQueue := TThreadedQueue.Create(cMyQueueDepth);
    aCounter := TCountDownEvent.Create(cThreadCount);
    try
      for i := 1 to cThreadCount do
        TMyConsumerItem.Create(aQueue, aCounter);
      for i := 0 to myListItems.Count - 1 do
      begin
        aQueue.PushItem(CaptureJob(myListItems[i]));
      end;

      for i := 1 to cThreadCount do
        aQueue.PushItem(nil);
    finally

      aThread := TThread.CreateAnonymousThread(
        procedure
        begin
          aCounter.WaitFor;
          aCounter.Free;
          aQueue.Free;
        end);
      aThread.FreeOnTerminate := false;
      aThread.Start;
      aThread.WaitFor;
      aThread.Free;
    end;
  finally
    Email.Free;
    SSLHandler.Free;
    IdSMTP.Free;
    IdSMTP.Disconnect;
  end;
end;

end.