Delphi7 send email in different thread and unit - delphi

I want to send email in other unit with different thread with indy10.0.52
I have source code
unit ThreadEmail;
interface
uses Classes, SysUtils, IdGlobal, IdMessage, IdIOHandler, IdIOHandlerSocket,
IdSSLOpenSSL, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
IdMessageClient, IdSMTP, IdExplicitTLSClientServerBase, IdSMTPBase,
IdIOHandlerStack, IdSSL, ExtCtrls;
type
TThreadEmail = class(TThread)
private
run : boolean;
counter : Integer;
target : Integer;
IdSMTP: TIdSMTP;
IdSSLIOHandlerSocketOpenSSL: TIdSSLIOHandlerSocketOpenSSL;
Messages : Array [0..10] of TIdMessage;
procedure checkRun();
protected
procedure Execute; override;
public
constructor Create(timerInS:Integer;host:string;port:integer;username,password:String;readTimeout : integer = 0);reintroduce;
function expressSend(recipients,subject,body:string;from:String='';replayTo:String='') :boolean;
function makeEmail(recipients,subject,body:string;from:String='';replayTo:String=''): boolean;
procedure SendAllEmail();
end;
implementation
constructor TThreadEmail.Create(timerInS:Integer;host:string;port:integer;username,password:String;readTimeout : integer = 0);
var b: byte;
begin
inherited Create(False);
Priority:= tpNormal;
FreeOnTerminate:= True;
IdSMTP := TIdSMTP.Create;
IdSSLIOHandlerSocketOpenSSL := TIdSSLIOHandlerSocketOpenSSL.Create();
for b:=low(Messages) to high(messages) do Messages[b] := nil;
IdSMTP.IOHandler := IdSSLIOHandlerSocketOpenSSL;
IdSMTP.UseTLS := utUseImplicitTLS;
IdSMTP.Host := host;
IdSMTP.Port := port;
IdSMTP.Username := username;
IdSMTP.Password := password;
IdSSLIOHandlerSocketOpenSSL.DefaultPort := 0;
IdSSLIOHandlerSocketOpenSSL.Destination := host+':'+inttostr(port);
IdSSLIOHandlerSocketOpenSSL.Host := host;
IdSSLIOHandlerSocketOpenSSL.MaxLineAction := maException;
IdSSLIOHandlerSocketOpenSSL.Port := port;
IdSSLIOHandlerSocketOpenSSL.ReadTimeout := readTimeout;
IdSSLIOHandlerSocketOpenSSL.SSLOptions.Method := sslvSSLv3;
IdSSLIOHandlerSocketOpenSSL.SSLOptions.Mode := sslmClient;
run:=true;
//target := timerInS*10;
end;
function TThreadEmail.expressSend(recipients,subject,body:string;from:String='';replayTo:String='') : boolean;
var IdMessage: TIdMessage;
begin
Result := false;
IdMessage := TIdMessage.Create();
IdMessage.Recipients.EMailAddresses := recipients;
IdMessage.Subject := subject;
IdMessage.Body.Text := body;
if from <> '' then IdMessage.From.Address := from;
if replayTo <> '' then IdMessage.ReplyTo.EMailAddresses := from;
try
IdSMTP.Connect();
IdSMTP.Send(IdMessage);
Result := true;
finally
IdSMTP.Disconnect();
end;
end;
function TThreadEmail.makeEmail(recipients,subject,body:string;from:String='';replayTo:String='') : boolean;
var b: byte;
begin
Result := false;
for b:=low(Messages) to high(messages) do
if Messages[b] = nil then
begin
Result := true;
Messages[b]:= TIdMessage.Create();
Messages[b].Recipients.EMailAddresses := recipients;
Messages[b].Subject := subject;
Messages[b].Body.Text := body;
if from <> '' then Messages[b].From.Address := from;
if replayTo <> '' then Messages[b].ReplyTo.EMailAddresses := from;
end;
if not(result) then
begin
SendAllEmail();
makeEmail(recipients,subject,body,from,replayTo);
end;
end;
procedure TThreadEmail.SendAllEmail();
var b: byte;
begin
try
IdSMTP.Connect();
for b:=low(Messages) to high(messages) do
if run and (Messages[b] <> nil) then
begin
try
IdSMTP.Send(Messages[b]);
finally
Messages[b].Free;
Messages[b] := nil;
end
end;
finally
IdSMTP.Disconnect();
end;
end;
procedure TThreadEmail.checkRun();
begin
Dec(counter);
if counter <= 0 then SendAllEmail();
end;
procedure TThreadEmail.Execute;
var b: byte;
begin
while run do
begin
sleep(100);
checkRun();
end;
IdSMTP.Free;
IdSSLIOHandlerSocketOpenSSL.Free;
for b:=low(Messages) to high(messages) do
if Messages[b] <> nil then Messages[b].Free;
end;
end.
and in mainfrom that i create
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ThreadEmail;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var ThreadEmail : TThreadEmail;
begin
ThreadEmail := ThreadEmail.Create(10,'smtp.gmail.com',465,'xxx.gmail.com','xxx',2000);
ThreadEmail.expressSend('xxx#yahoo.com','TES','TES');
end;
When button1 clicked, it always "create access violation error", Why it happend? can anyone help me? as a info, i sucesed send a email before, but i want to make a singgle unit that can run alone.
thanks

ThreadEmail := ThreadEmail.Create(10,'s....
this should be :
ThreadEmail := TThreadEmail.Create(10,'s....
Not sure if that's just a typo? It will definitely cause an AV if not.
In any case, ThreadEmail.expressSend will not run in your TThread's thread the way you are calling it. When you run a TThread the code in its Execute method will run in a separate thread. Any of the public member methods, however, can be called on an instance just like public methods of any class and they are executed on the thread that calls them.
To get this to work you need to have the Execute method performing the calls to send the email message. The UI thread needs to trigger action in the Execute method and not perform the action itself; this can be done by any number of means (having Execute synchronize with WaitForSingleObject, via message passing, etc).
The rest of your code looks rather broken. Your Execute code is not really going to work as it is - this loop :
while run do
begin
sleep(100);
checkRun();
end;
will never terminate as it seems you don't set run to false anywhere. Furthermore, counter does not seem to get set anywhere (nor do I really understand its purpose) so this will just SendAllEmail() every 100ms or so.
The makeEmail function will never terminate (stack overflow) since it calls itself recursively with the original arguments and the logic guarantees re-entry on each pass. It also looks like it will send whatever message eleven times on each recursion (since all 11 elements of Messages will be nil after initialization and after each call to SendAllEmail().
Even if you fix this - if you are calling makeEmail externally (ie: from the UI or another thread) then this will likely end up with all sorts of cross-thread errors since both Execute and the calling thread will be trying to call SendAllEmail at the same time. This code will need some work.

Related

TIdNotify.Notify() doesn't work when called from TIdTCPServer

I have a Lazarus console app where I have a simple TIdTCPServer. To be a thread safe app, I added TLog.LogMsg() (which uses TIdNotify).
The problem is, when I call this function from the main thread, the message appears on the console, but when it is called from the OnExecute or OnConnect event of TIdTCPServer, the message is not displayed.
Can you help me with this problem?
program Srv;
{$I Synopse.inc}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Classes, SysUtils, CustApp, Generics.Collections, IdTCPServer, IdCustomTCPServer, IdContext, IdGlobal, Db, mORMot, mORMotSQLite3, IdSync, functions, SynCommons, SynSQLite3Static;
type
{ TMyApplication }
TMyApplication = class(TCustomApplication)
var IdTCPServer: TIdTCPServer;
protected
procedure DoRun; override;
procedure ServerOnConnect(AContext: TIdContext);
procedure ServerOnExecute(AContext: TIdContext);
public
constructor Create(TheOwner: TComponent); override;
destructor Destroy; override;
end;
type
TLog = class(TIdNotify)
protected
FMsg: string;
procedure DoNotify; override;
public
class procedure LogMsg(const AMsg: string);
end;
{ TMyApplication }
procedure TLog.DoNotify;
var i:integer;
begin
writeln(FMsg);
end;
class procedure TLog.LogMsg(const AMsg: string);
begin
with TLog.Create do
try
FMsg := AMsg;
Notify;
except
Free;
raise;
end;
end;
procedure TMyApplication.ServerOnExecute(AContext: TIdContext);
begin
TLog.LogMsg('test OnExecute'); // the message is not displayed
end;
procedure TMyApplication.ServerOnConnect(AContext: TIdContext);
begin
TLog.LogMsg('connect'); // the message is not displayed
end;
procedure TMyApplication.DoRun;
begin
TLog.LogMsg('test main 1'); //the message is displayed
IdTCPServer := TIdTCPServer.Create;
try
//Server.Name := 'Server';
IdTCPServer.ListenQueue := 15;
IdTCPServer.MaxConnections := 0;
IdTCPServer.TerminateWaitTime := 5000;
IdTCPServer.Bindings.Add.IP := '0.0.0.0';
IdTCPServer.Bindings.Add.Port := 80;
IdTCPServer.Bindings.Add.IPVersion:=Id_IPv4;
IdTCPServer.OnConnect := ServerOnConnect;
// IdTCPServer.OnDisconnect := ServerOnDiconnect;
//Server.OnException := IdTCPServer1Exception;
IdTCPServer.OnExecute := ServerOnExecute;
IdTCPServer.Active := True;
TLog.LogMsg('test main 2'); //the message is displayed
finally
// IdTCPServerCmd.Free;
end;
readln;
// stop program loop
Terminate;
end;
constructor TMyApplication.Create(TheOwner: TComponent);
begin
inherited Create(TheOwner);
StopOnException := True;
end;
destructor TMyApplication.Destroy;
begin
IdTCPServer.Free;
inherited Destroy;
end;
var
Application: TMyApplication;
begin
Application := TMyApplication.Create(nil);
Application.Title := 'My Application';
Application.Run;
Application.Free;
end.
Your main thread does not have a message loop to process TThread.Synchronize()/TThread.Queue() requests. It is blocked on Readln(). Since you are in a console app and not a GUI app, you need to manually call Classes.CheckSynchronize() periodically in the main thread.
On a side note, you are calling IdTCPServer.Bindings.Add() too many times. In your example, you need to call it only 1 time, creating 1 binding that has the 3 property values assigned to it. But instead, you are calling it 3 times, creating 3 separate bindings with 3 separate property settings. It should look more like this instead:
with IdTCPServer.Bindings.Add do
begin
IP := '0.0.0.0';
Port := 80;
IPVersion := Id_IPv4;
end;
Which can be simplified as 0.0.0.0 and Id_IPv4 are already the default values, so they can be omitted from your code. And TIdTCPServer has a DefaultPort property you can use instead. The TIdTCPServer.Active property setter will create its own default bindings if there are none defined explicitly.

Unable to a print in Windows 10 when Delphi / QuickReport is within a DLL

Delphi 7 / QuickReport 5.02.2
We've used similar code for several years but have run into an issue recently now that we're migrating workstations to Windows 10. Previously, we were using Windows 7 and all was fine. Maybe there's something I'm missing or doing wrong?
Here's a simple test project I put together to test this. When the report is within a DLL every call to Printer.GetPrinter fails in Windows 10. Though, if the report is on a form within the main application it works fine.
Below is the code, and a zipped up folder for anyone that's interested. There is the dependency on QuickReport though, which can't be helped. Thanks for looking.
https://1drv.ms/u/s!AsbtokV75aocsXM6MQZcrvwpHKcg
DLL Project.
library test_dll;
uses
SysUtils,
Classes,
Forms,
report in 'report.pas' {report_test};
{$R *.res}
function Report_Print(PrinterName: Widestring): Integer; export;
var
Receipt: Treport_test;
begin
try
Receipt := Treport_test.Create(nil);
try
Receipt.Print(PrinterName);
Receipt.Close;
finally
Receipt.Free;
end;
except
Application.HandleException(Application.Mainform);
end;
Result := 1;
end;
exports
Report_Print;
begin
end.
Report Unit
unit report;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, QRCtrls, QuickRpt, ExtCtrls, Printers, QRpCtrls, QRPrntr;
type
Treport_test = class(TForm)
QuickRep1: TQuickRep;
DetailBand1: TQRBand;
TitleBand1: TQRBand;
QRLabel1: TQRLabel;
SummaryBand1: TQRBand;
QRLabel2: TQRLabel;
QRLabel3: TQRLabel;
private
{ Private declarations }
public
{ Public declarations }
procedure Print(const PrinterName: string);
end;
var
report_test: Treport_test;
procedure SetupPrinter(QuickRep: TQuickRep; const PrinterName: string);
function SelectPrinter(QuickRep: TQuickRep; const PrinterName: string): boolean;
implementation
var
DLL_QRPrinter: TQRPrinter;
{$R *.dfm}
function SelectPrinter(QuickRep: TQuickRep; const PrinterName: string): boolean;
var
i: integer;
compareLength: integer;
windowsPrinterName: string;
selectedPrinter: Integer;
defaultPrinterAvailable: Boolean;
begin
defaultPrinterAvailable := True;
try // an exception will occur if there is no default printer
i := Printer.printerIndex;
if i > 0 then ; // this line is here so Delphi does not generate a hint
except
defaultPrinterAvailable := False;
end;
compareLength := Length(PrinterName);
if (not Assigned(QuickRep.QRPrinter)) then
begin
QuickRep.QRPrinter := DLL_QRPrinter;
end;
// Look for the printer.
selectedPrinter := -1;
// Attempt #1: first try to find an exact match
for i := 0 to QuickRep.QRPrinter.Printers.Count - 1 do
begin
windowsPrinterName := Copy(QuickRep.QRPrinter.Printers.Strings[i], 1, compareLength);
if (UpperCase(windowsPrinterName) = UpperCase(PrinterName)) then
begin
selectedPrinter := i;
Break;
end;
end;
// Attempt #2: if no exact matches, look for the closest
if (selectedPrinter < 0) then
for i := 0 to QuickRep.QRPrinter.Printers.Count - 1 do
begin
windowsPrinterName := Copy(QuickRep.QRPrinter.Printers.Strings[i], 1, compareLength);
if (Pos(UpperCase(PrinterName), UpperCase(QuickRep.QRPrinter.Printers.Strings[i])) > 0) then
begin
selectedPrinter := i;
Break;
end;
end;
// Attempt #3: if no exact matches, and nothing close, use default printer
if (selectedPrinter < 0) and (defaultPrinterAvailable) then
selectedPrinter := QuickRep.Printer.printerIndex;
Result := False;
if (selectedPrinter > -1) then
begin
QuickRep.PrinterSettings.PrinterIndex := selectedPrinter;
Result := True;
end;
end;
procedure SetupPrinter(QuickRep: TQuickRep; const PrinterName: string);
begin
//check if we have the default printer instead of the selected printer
SelectPrinter(QuickRep, PrinterName);
QuickRep.Page.Units := Inches;
QuickRep.Page.Length := 11;
end;
procedure Treport_test.Print(const PrinterName: string);
begin
SetupPrinter(QuickRep1, PrinterName);
QuickRep1.Print;
end;
initialization
DLL_QRPrinter := TQRPrinter.Create(nil);
finalization
DLL_QRPrinter.Free;
DLL_QRPrinter := nil;
end.
Test Application
program Project1;
uses
Forms,
Unit1 in 'Unit1.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Main Form
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, QRPrntr,
Dialogs, StdCtrls, QuickRpt, QRCtrls, ExtCtrls, Printers, QRPCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TPrintReport = function(PrinterName: Widestring): Integer;
var
Form1: TForm1;
procedure PrintReport(const PrinterName: string);
implementation
var
DLLHandle: THandle = 0;
POS: TPrintReport = nil;
{$R *.dfm}
procedure PrintReport(const PrinterName: string);
begin
try
POS(PrinterName);
except on e: Exception do
ShowMessage(e.Message);
end;
end;
procedure LoadDLL;
var
DLLName: string;
DLLRoutine: PChar;
begin
DLLName := 'test_dll.dll';
DLLRoutine := 'Report_Print';
if not (FileExists(DLLName)) then
raise Exception.CreateFmt('The DLL "%s" is missing. Build the DLL project and try again.', [DLLName]);
Application.ProcessMessages;
DLLHandle := LoadLibrary(PChar(DLLName));
Application.ProcessMessages;
if (DLLHandle = 0) then
raise Exception.CreateFmt('Error: %s, while attempting to load DLL %s.', [IntToStr(GetLastError), DLLName]);
POS := GetProcAddress(DLLHandle, DLLRoutine);
if (#POS = nil) then
raise Exception.CreateFmt('Error: %s, while attempting get address to %s in DLL %s.', [IntToStr(GetLastError), DLLRoutine, DLLName]);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
LoadDLL;
ShowMessage('dll loaded');
PrintReport('MyPrinter');
FreeLibrary(DLLHandle);
end;
end.
Snippet from QuickReport
procedure TPrinterSettings.ApplySettings;
var
Cancel : boolean;
begin
FPrinter.GetPrinter(FDevice, FDriver, FPort, DeviceMode);
DevMode := GlobalLock(DeviceMode);
begin
SetField(dm_paperlength);
...
DeviceMode is 0, so SetField throws an access violation. See below.
Access violation at address 036BFBA7 in module 'test_dll.dll'. Write of address 00000028.
Try comment out those 2 lines for GetPrinter and for DevMode
procedure TPrinterSettings.ApplySettings;
var
Cancel : boolean;
begin
// FPrinter.GetPrinter(FDevice, FDriver, FPort, DeviceMode);
// DevMode := GlobalLock(DeviceMode);
begin
SetField(dm_paperlength);
...
end
uses ComObj, ActiveX, StdVcl;
if Printer.Printers.Count>0 then
begin
FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
FWMIService := FSWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
FWbemObject := FWMIService.Get(Format('Win32_Printer.DeviceID="%s"',[Printer.Printers.Strings[0]]));
if not VarIsClear(FWbemObject) then
FWbemObject.SetDefaultPrinter();
end;
new solution
Windows 10 have not default printer with this code u can set the default printer

IdTcpClient repeat ReadLn command

I want to make a function on the Idtcpclient that repeats the ReadLn command.
But how can i do this? I don't want to use a timer because a timer is slow.
I allready searched on google but i don't understand it..
The client can be placed in a separate thread, and use a loop to repeat the ReadLn until it succeeds. The time out can be given as an argument to ReadLn so that the next try will happen after the timeout interval. Make sure to handle connection loss, for example by reconnecting in a loop.
I create a unit to my program, I hope to help you:
unit uSerialAuthentication;
interface
uses System.SysUtils, IdTCPClient, IdThreadComponent, FMX.Dialogs;
type
TSerialAuthentication = class (TObject)
IdTCPClient: TIdTCPClient;
procedure IdThreadComponentRun(Sender: TIdThreadComponent);
public
constructor Create (Host : string; Port: Word);
destructor Destroy; override;
procedure OnConnect(Sender: TObject);
end;
var
idThreadComponent : TIdThreadComponent; // Thread
Access : Boolean;
implementation
{ SerialAuthentication }
procedure TSerialAuthentication.OnConnect(Sender: TObject);
begin
ShowMessage('Connected');
IdThreadComponent.Active := True;
end;
constructor TSerialAuthentication.Create(Host : string; Port: Word);
begin
IdTCPClient := TIdTCPClient.Create();
IdTCPClient.Host := Host;
IdTCPClient.Port := Port;
IdTCPClient.OnConnected := OnConnect;
idThreadComponent := TIdThreadComponent.Create();
idThreadComponent.OnRun := IdThreadComponentRun;
Access := False;
end;
destructor TSerialAuthentication.Destroy;
begin
IdTCPClient.Disconnect;
if idThreadComponent.active then
begin
idThreadComponent.active := False;
end;
FreeAndNil(IdThreadComponent);
if Assigned(IdTCPClient) then
FreeAndNil (IdTCPClient);
inherited;
end;
procedure TSerialAuthentication.IdThreadComponentRun(Sender: TIdThreadComponent);
var
recv : String;
begin
recv := IdTCPClient.IOHandler.ReadLn(); // READ
if length(recv)>0 then
if recv = 'Ready' then
Access := True
else
Access := False;
end;
end.

Building HTTP Server Application

I have a project which does financial reports and I want to let user to be able to get this reports through the internet
I tried using TIdHTTPServer which is an Indy component to make my application to work as an HTTP Server and to let it to be able
receive request -> process the request -> send back the result of the request process
using a special port.
now my problem is that I'm getting a lot of Access Violation errors and random exceptions
it looks like about threads problem or I don't know because if I process the same request without using the TIdHTTPServer I don't get any problem
i'm using the OnCommandGet Event to process the request and send the result back to user inside the context stream.
what I need is a demonstration on how to use it with TADODataSet and TADOConnection
for example I need the user to be able to send a request and the TIdHTTPServer takes the request (for example call a stored procedure using to ADODataSet and take the result as XML file and send it back to the user)
please help....thank you.
one possibility how a Server could work ...
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,IDContext, IdBaseComponent, IdComponent, IdCustomTCPServer, IdTCPServer, StdCtrls, DB, ADODB;
type
TForm3 = class(TForm)
IdTCPServer1: TIdTCPServer;
Memo1: TMemo;
Button1: TButton;
DummyConnection: TADOConnection;
procedure Button1Click(Sender: TObject);
procedure IdTCPServer1Execute(AContext: TIdContext);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
uses ComObj,AdoInt,ActiveX;
{$R *.dfm}
function SendStream(AContext: TIdContext; AStream: TStream): Boolean;
begin
Result := False;
try
AContext.Connection.IOHandler.Write(AStream.Size); // sending length of Stream first
AContext.Connection.IOHandler.WriteBufferOpen;
AContext.Connection.IOHandler.Write(AStream, AStream.Size);
AContext.Connection.IOHandler.WriteBufferFlush;
finally
AContext.Connection.IOHandler.WriteBufferClose;
end;
Result := True;
end;
procedure TForm3.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := true;
end;
{ Clientside function
Function RecordsetFromXMLStream(Stream:TStream): _Recordset;
var
RS: Variant;
begin
RS := CreateOleObject('ADODB.Recordset');
RS.Open(TStreamAdapter.Create(Stream) as IUnknown);
Result := IUnknown(RS) as _Recordset;
end;
}
Procedure RecordsetToXMLStream(const Recordset: _Recordset;Stream:TStream);
var
RS: Variant;
begin
if Recordset = nil then Exit;
RS := CreateOleObject('ADODB.Recordset');
RS := Recordset;
RS.Save(TStreamAdapter.Create(stream) as IUnknown, adPersistXML);
Stream.Position := 0;
end;
Procedure GetQueryStream(Const s,ConStr:String;ms:TMemoryStream);
var
AC:TAdoConnection;
ads:TAdodataset;
begin
AC:=TAdoConnection.Create(nil);
try
ads:=TAdodataset.Create(nil);
try
ads.Connection := AC;
AC.ConnectionString := ConStr;
ads.CommandText := s;
ads.Open;
RecordsetToXMLStream(ads.Recordset,ms);
finally
ads.Free
end;
finally
AC.Free
end;
end;
procedure TForm3.IdTCPServer1Execute(AContext: TIdContext);
var
cmd:String;
ms:TMemoryStream;
begin
CoInitialize(nil);
AContext.Connection.IOHandler.Readln(cmd);
ms:=TMemoryStream.Create;
try
GetQueryStream('Select * from Adressen',DummyConnection.ConnectionString,ms);
ms.Position := 0;
SendStream(AContext,ms);
AContext.Connection.Socket.CloseGracefully;
finally
ms.Free;
CoUninitialize;
end;
end;
end.

TIdTCPServer.OnExecute in a console application

I need to write a Delphi 2009 application, which reads data from a socket. To do this, I need to write an event handler for the TIdTCPServer.OnExecute event.
I found lots of examples for implementing this in GUI applications, but I need to do it in a console application (without any windows).
How should I modify the code below in order to add an event handler (attach it to TCPServer), which prints every received message into the debug output?
unit ReceivingThreadUnit;
interface
uses
Classes,
IdTCPServer,
IdSocketHandle,
SysUtils,
Windows;
type
ReceivingThread = class(TThread)
private
TCPServer: TIdTCPServer;
public
procedure Run();
end;
implementation
procedure ReceivingThread.Run();
var
Bindings: TIdSocketHandles;
begin
TCPServer := TIdTCPServer.Create(nil);
//setup and start TCPServer
Bindings := TIdSocketHandles.Create(TCPServer);
try
with Bindings.Add do
begin
IP := '127.0.0.1';
Port := 9998;
end;
try
TCPServer.Bindings:=Bindings;
// Here I want to attach TCPServer to an OnExecute event handler
TCPServer.Active:=True;
except on E:Exception do
OutputDebugString(PChar(E.ToString));
end;
finally
Bindings.Free;
TCPServer.Free;
end;
TCPServer.Active := true;
end;
end.
As David said (but did not fully show), you need to declare a method in your thread class and then assign it to the OnExecute event.
On a side note, you should not be creating a TIdSocketHandles collection manually. Call Add() on the existing TIdTCPServer.Bindings collection instead.
Try this:
unit ReceivingThreadUnit;
interface
uses
Classes,
IdTCPServer,
IdSocketHandle,
IdContext,
SysUtils,
Windows;
type
ReceivingThread = class(TThread)
private
TCPServer: TIdTCPServer;
procedure ExecuteHandler(AContext: TIdContext);
public
procedure Run;
end;
implementation
procedure ReceivingThread.ExecuteHandler(AContext: TIdContext);
begin
//...
end;
procedure ReceivingThread.Run;
begin
//setup and start TCPServer
TCPServer := TIdTCPServer.Create(nil);
try
with TCPServer.Bindings.Add do
begin
IP := '127.0.0.1';
Port := 9998;
end;
TCPServer.OnExecute := ExecuteHandler;
try
TCPServer.Active := True;
except
on E: Exception do
OutputDebugString(PChar(E.ToString));
end;
while not Terminated do
Sleep(1000);
TCPServer.Active := False;
finally
TCPServer.Free;
end;
end;
end.
With that said, your receiveing thread is actually pretty redundant since TIdTCPServer is already multi-threaded, so you could alternatively just eliminate the thread class altogether:
program MyApp;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Classes,
IdTCPServer,
IdSocketHandle,
IdContext,
SysUtils,
Windows;
type
TCPServerEvents = class
public
class procedure ExecuteHandler(AContext: TIdContext);
end;
class procedure TCPServerEvents.ExecuteHandler(AContext: TIdContext);
begin
//...
end;
var
TCPServer: TIdTCPServer;
begin
//setup and start TCPServer
TCPServer := TIdTCPServer.Create(nil);
try
with TCPServer.Bindings.Add do
begin
IP := '127.0.0.1';
Port := 9998;
end;
TCPServer.OnExecute := TCPServerEvents.ExecuteHandler;
try
TCPServer.Active := True;
except
on E: Exception do
OutputDebugString(PChar(E.ToString));
end;
while (not stop condition) do
Sleep(1000);
TCPServer.Active := False;
finally
TCPServer.Free;
end;
end.
You need to add an event handler to your class. And then connect it up:
TCPServer.OnExecute := Self.ExecuteHandler;

Resources