Hallo zusammen,

ich habe versucht den Lesethread von hier umzusetzen.

markieren

Code:

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdBaseComponent, IdComponent, idsync,
  IdTCPConnection, IdTCPClient, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    MemoReceive: TMemo;
    Button1: TButton;
    Client: TIdTCPClient;
    Button2: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure ClientConnected(Sender: TObject);
    procedure ClientDisconnected(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TReadingThread = class(TThread)
  protected
    FConn: TIdTCPConnection;
    procedure Execute; override;
    procedure DoTerminate; override;
  public
    constructor Create(AConn: TIdTCPConnection); reintroduce;
  end;

  TLog = class(TidSync)
  protected
    FMsg: String;
    procedure DoSynchronize; override;
  public
    constructor Create(const AMsg: String);
    class procedure AddMsg(const AMsg: String);
  end;

var
  Form1: TForm1;
  rt: TReadingThread = nil;

implementation

var
  oldStatusReceive: string = 'Disconnected';
  oldStatusSend: string = 'Disconnected';
  TelegramNr: string = '00';
  sendCounter: Integer = 1;
  CommissionNumber: Integer = 1;

{$R *.dfm}

constructor TReadingThread.Create(AConn: TIdTCPConnection);
begin
  TLog.AddMsg('DEBUG: TReadingThread.Create');
  FConn := AConn;
  inherited Create(False);
end;

procedure TReadingThread.Execute;
var
  cmd, tcpStringSend: string;
begin
  TLog.AddMsg('DEBUG: TReadingThread.Execute');

  while not Terminated do
  begin
    cmd := FConn.IOHandler.ReadLn(#3);
    cmd := trim(cmd);
    TLog.AddMsg('DEBUG: TReadingThread.Execute. Cmd: ' + cmd);
    TelegramNr := copy(cmd, 1, 2);
    tcpStringSend := #2 + TelegramNr + '001050QU' + #3;
    FConn.IOHandler.WriteLn(tcpStringSend);
  end;
end;

procedure TReadingThread.DoTerminate;
begin
  TLog.AddMsg('DEBUG: TReadingThread.DoTerminate');
  inherited;
end;

constructor TLog.Create(const AMsg: string);
begin
  inherited Create;
  FMsg := AMsg;
end;

procedure TLog.DoSynchronize;
begin
  Form1.MemoReceive.Lines.Add(FMsg);
end;

class procedure TLog.AddMsg(const AMsg: string);
begin
  with Create(AMsg) do
    try
      Synchronize;
    finally
      Free;
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Host: string;
  Port: Integer;
begin
  Host := '192.168.100.74';
  Port := StrToInt('4100');

  Client.Host := Host;
  Client.Port := Port;

  try
    Client.Connect;
  except
    on E: Exception do
      TLog.AddMsg('Error: ' + E.Message);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  try
    Client.Disconnect;
  except
    on E: Exception do
      TLog.AddMsg('Error: ' + E.Message);
  end;
end;

procedure TForm1.ClientConnected(Sender: TObject);
begin
  TLog.AddMsg('DEBUG: TForm1.clientConnected');
  rt := TReadingThread.Create(Client);
end;

procedure TForm1.ClientDisconnected(Sender: TObject);
begin
  TLog.AddMsg('DEBUG: TForm1.clientDisconnected');
  if rt <> nil then
  begin
    rt.Terminate;
    rt.WaitFor;
    FreeAndNil(rt);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  MemoReceive.Clear;
end;

end.

Wie lässt sich die Verbindung sicher beenden? Ich habe einen Disconnect Button hinzugefügt, aber wenn ich da drauf klicke bekomme ich eine Exception (Project1.exe raised exception class EIdNotConnected with message 'Not Connected'.) Ich nehme an, dass passiert, weil der Lesethread noch läuft und dann plötzlich die Verbindung weg ist. Wenn ich die Anwendung nach dem Verbinden einfach schließe passiert das gleiche. Ich muss also erst den Lesethread beenden und dann die Verbindung kappen. Wie beende ich den Thread, wenn er gerade beim "ReadLn" hängt und vom Server da nichts kommt? Ich habe versucht das Terminate, WaitFor, FreeAndNil vom Disconnected Event vor dem Disconnect zu machen aber dann friert die Anwendung einfach ein. Hat einer eine Idee?

Hallo,

versuch mal vor dem "Disconnect" den InputBuffer zu leeren.

zusammenfalten · markieren

Delphi-Quellcode:

procedure TForm1.Button2Click(Sender: TObject);
 begin
   //***
   Client.IOHandler.InputBuffer.Clear;
   //***
   try
     Client.Disconnect;
   except
     on E: Exception do
       TLog.AddMsg('Error: ' + E.Message);
   end;
 end;

Sollte es immer noch Probleme geben, dann kommentiere zusätzlich die Zeile:
FConn.IOHandler.WriteLn(tcpStringSend);
testweise einmal aus.

Hallo,

das Thema hat mir keine Ruhe gelassen, da ich selber dieses Problem in eigenen Projekten habe bzw. hatte.
Eine Exception trat in meinen Programmen aber nur auf, wenn ich es aus der IDE mit dem Debugger gestartet habe.

Als kleines Beispiel habe ich Deine Thread-Klasse etwas umgebaut. Die Events TForm1.ClientConnected und TForm1.ClientDisconnected
habe ich ganz rausgenommen. Der Schreibvorgang Client.IOHandler.WriteLn(tcpStringSend); liegt jetzt im Hauptthread von Form1.
Vielleicht hilft das ein bischen.

zusammenfalten · markieren

Delphi-Quellcode:

interface

const
  WM_CLIENTANSWER = WM_USER+1;

//*** TReadingThread
type
  TReadingThread= class(TThread)
  private
    FOutStr: string;
    FClient: TIdTCPClient;
    procedure HandleInput;
  protected
    procedure Execute; override;
  public
    constructor Create(ATCPClient: TIdTCPClient);
  end;

//*** TForm1

type
  TForm1 = class(TForm)
    //...
  private
    { Private-Deklarationen }
    procedure AnswerEvent(var Msg: TMessage); Message WM_CLIENTANSWER;
    //...
  end;

//...


implementation

constructor TReadingThread.Create(AClient: TIdTCPClient);
 begin
   TLog.AddMsg('DEBUG: TReadingThread.Create');
   FClient := AClient;
   inherited Create(False);
 end;

procedure TReadingThread.HandleInput;
var
   cmd: string;
begin
  if FClient.Connected then
  begin
    try
      cmd:=FClient.IOHandler.ReadLn(#3);
      TLog.AddMsg('DEBUG: TReadingThread.Execute. Cmd: ' + cmd);
    except
      on E: Exception do
      begin
        cmd:=E.Message;
        TLog.AddMsg('DEBUG: TReadingThread.Execute. Err: ' + cmd);
      end;
    end;

    PostMessage(Form1.Handle,WM_CLIENTANSWER,integer(@cmd),0);

  end else Terminate;
end;

procedure TReadingThread.Execute;
begin
  while not Terminated do
  begin
    HandleInput;
  end;
end;

procedure TForm1.AnswerEvent(var Msg: TMessage); //Antwort vom Thread übernehmen
var
  CmdStr, tcpStringSend: String;
  P: ^string;
begin
  P:=Pointer(Msg.WParam);
  CmdStr:=P^;
  TelegramNr := copy(CmdStr, 1, 2);
  tcpStringSend := #2 + TelegramNr + '001050QU' + #3;

  if Client.Connected then Client.IOHandler.WriteLn(tcpStringSend); //Nur schreiben, wenn Verbindung noch besteht!
end;

procedure TForm1.Button1Click(Sender: TObject);
 var
   Host: string;
   Port: Integer;
 begin
   Host := '192.168.100.74';
   Port := StrToInt('4100');

   Client.Host := Host;
   Client.Port := Port;

   try
     Client.Connect;
   except
     on E: Exception do
       TLog.AddMsg('Error: ' + E.Message);
   end;

   if Client.Connected then rt:=TReadingThread.Create(Client);

 end;

procedure TForm1.Button2Click(Sender: TObject); //Disconnect reicht; der Thread terminiert sich selbst!
begin
   Client.IOHandler.InputBuffer.Clear;

  try
    Client.Disconnect;
  except
    on E: Exception do
       TLog.AddMsg('Error: ' + E.Message);
  end;
end;

Hallo Ich kann es leider zur Zeit noch nicht testen, da ich zur Zeit nicht an das Entwicklungssystem rankomme. Ich melde mich sobald ich das getestet habe. Vielen Dank für die Vorschläge.

So, dein erster Vorschlag hat nicht funktioniert. Den zweiten kann ich nicht so einfach übernehmen, da ich zwei Clients gleichzeitig am laufen habe. Ich poste mal meinen gesamten Code. Es geht hier um die Kommunikation mit einem KBS Pick-by-light System.

zusammenfalten · markieren

Delphi-Quellcode:

unit KBS;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdBaseComponent, IdComponent, idsync,
  IdTCPConnection, IdTCPClient, Vcl.StdCtrls, Vcl.ExtCtrls, IdGlobal;

type
  TForm1 = class(TForm)
    MemoReceive: TMemo;
    Button1: TButton;
    ClientReceive: TIdTCPClient;
    Button2: TButton;
    ClientSend: TIdTCPClient;
    Button3: TButton;
    MemoSend: TMemo;
    Edit1: TEdit;
    Label1: TLabel;
    Button4: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure ClientReceiveConnected(Sender: TObject);
    procedure ClientReceiveDisconnected(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure ClientSendConnected(Sender: TObject);
    procedure ClientSendDisconnected(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TReadingThread = class(TThread)
  protected
    FConn: TIdTCPConnection;
    procedure Execute; override;
    procedure DoTerminate; override;
  public
    constructor Create(AConn: TIdTCPConnection); reintroduce;
  end;

  TWritingThread = class(TThread)
  protected
    FConn: TIdTCPConnection;
    procedure Execute; override;
    procedure DoTerminate; override;
  public
    constructor Create(AConn: TIdTCPConnection); reintroduce;
  end;

  TLogReceive = class(TidSync)
  protected
    FMsg: String;
    procedure DoSynchronize; override;
  public
    constructor Create(const AMsg: String);
    class procedure AddMsg(const AMsg: String);
  end;

  TLogSend = class(TidSync)
  protected
    FMsg: String;
    procedure DoSynchronize; override;
  public
    constructor Create(const AMsg: String);
    class procedure AddMsg(const AMsg: String);
  end;

var
  KBSForm: TForm1;
  rt: TReadingThread = nil;
  wt: TWritingThread = nil;

  (*
    WelchesLicht: Name Lichtes, in WinKomm Basis heißt es "Adresse"
    ObenFarbe: 'rot', 'gruen', 'blau', 'gelb', 'cyan', 'magenta', 'weiß'
    Obenlicht: 0 ist aus, 1 ist an, 2 ist blinken und 3 ist blinken in der gegengesezten Phase zu 2
    UntenFarbe und UntenLicht genau wie Oben*
    Rückgabe: Fehlertext oder leer
  *)
function LichtSteuern(WelchesLicht: string; ObenFarbe: string;
  ObenLicht: Integer; UntenFarbe: string; UntenLicht: Integer): string;

implementation

uses
  t_zeiten, System.IniFiles;

var
  TelegramNr: string = '00';
  LVdelay: Cardinal;
  sendCounter: Integer = 1;
  CommissionNumber: Integer = 1;
  SendeString: string = '';
{$R *.dfm}

constructor TReadingThread.Create(AConn: TIdTCPConnection);
begin
  TLogReceive.AddMsg('DEBUG: TReadingThread.Create');
  FConn := AConn;
  inherited Create(False);
end;

constructor TWritingThread.Create(AConn: TIdTCPConnection);
begin
  TLogSend.AddMsg('DEBUG: TWritingThread.Create');
  FConn := AConn;
  inherited Create(False);
end;

procedure TReadingThread.Execute;
var
  cmd, tcpStringSend: string;
begin
  TLogReceive.AddMsg('DEBUG: TReadingThread.Execute');

  while not Terminated do
  begin
    cmd := FConn.IOHandler.ReadLn(#3, IndyTextEncoding_ASCII);
    cmd := trim(cmd);
    TLogReceive.AddMsg('Rcv: ' + cmd);
    TelegramNr := copy(cmd, 1, 2);
    tcpStringSend := #2 + TelegramNr + '001050QU' + #3;
    FConn.IOHandler.WriteLn(tcpStringSend, IndyTextEncoding_ASCII);
    TLogReceive.AddMsg('Send: ' + trim(tcpStringSend));
  end;
end;

procedure TWritingThread.Execute;
var
  cmd, tcpStringSend, CommissionNumberS, SendCounterS: string;
begin
  TLogSend.AddMsg('DEBUG: TWritingThread.Execute');
  while not Terminated do
  begin
    tcpStringSend := '';
    SendCounterS := '';
    CommissionNumberS := '';
    if elapsedtime(LVdelay) > 10 then
    begin
      if sendCounter > 99 then
        sendCounter := 1;
      SendCounterS := IntToStr(sendCounter);
      if length(SendCounterS) < 2 then
        SendCounterS := '0' + SendCounterS;
      tcpStringSend := #2 + SendCounterS + '001050LV' + #3;
      FConn.IOHandler.WriteLn(tcpStringSend, IndyTextEncoding_ASCII);
      TLogSend.AddMsg('Send: ' + trim(tcpStringSend));
      inc(sendCounter);
      marktime(LVdelay);
      cmd := FConn.IOHandler.ReadLn(#3, IndyTextEncoding_ASCII);
      cmd := trim(cmd);
      TLogSend.AddMsg('Rcv: ' + cmd);
    end;
    if SendeString <> '' then
    begin
      if sendCounter > 99 then
        sendCounter := 1;
      SendCounterS := IntToStr(sendCounter);
      if length(SendCounterS) < 2 then
        SendCounterS := '0' + SendCounterS;
      if CommissionNumber > 9990 then
        CommissionNumber := 1;
      CommissionNumberS := IntToStr(CommissionNumber);
      while length(CommissionNumberS) < 4 do
        CommissionNumberS := '0' + CommissionNumberS;
      tcpStringSend := #2 + SendCounterS + '001050DILampe1 ' +
        CommissionNumberS + #27 + SendeString + #3;
      SendeString := '';
      FConn.IOHandler.WriteLn(tcpStringSend, IndyTextEncoding_ASCII);
      TLogSend.AddMsg('Send: ' + trim(tcpStringSend));
      inc(sendCounter);
      inc(CommissionNumber);
      cmd := FConn.IOHandler.ReadLn(#3, IndyTextEncoding_ASCII);
      cmd := trim(cmd);
      TLogSend.AddMsg('Rcv: ' + cmd);
    end;

  end;

end;

procedure TReadingThread.DoTerminate;
begin
  TLogReceive.AddMsg('DEBUG: TReadingThread.DoTerminate');
  inherited;
end;

procedure TWritingThread.DoTerminate;
begin
  TLogSend.AddMsg('DEBUG: TWritingThread.DoTerminate');
  inherited;
end;

constructor TLogReceive.Create(const AMsg: string);
begin
  inherited Create;
  FMsg := AMsg;
end;

constructor TLogSend.Create(const AMsg: string);
begin
  inherited Create;
  FMsg := AMsg;
end;

procedure TLogReceive.DoSynchronize;
begin
  KBSForm.MemoReceive.Lines.Add(FMsg);
end;

procedure TLogSend.DoSynchronize;
begin
  KBSForm.MemoSend.Lines.Add(FMsg);
end;

class procedure TLogReceive.AddMsg(const AMsg: string);
begin
  with Create(AMsg) do
    try
      Synchronize;
    finally
      Free;
    end;
end;

class procedure TLogSend.AddMsg(const AMsg: string);
begin
  with Create(AMsg) do
    try
      Synchronize;
    finally
      Free;
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin

  try
    ClientReceive.Connect;
  except
    on E: Exception do
      TLogReceive.AddMsg('Error: ' + E.Message);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ClientReceive.IOHandler.InputBuffer.Clear;
  ClientSend.IOHandler.InputBuffer.Clear; // xx TEST

  try
    ClientReceive.Disconnect;
    ClientSend.Disconnect;
  except
    on E: Exception do
      TLogReceive.AddMsg('Error: ' + E.Message);
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  if ClientSend.Connected then
  begin
    ClientSend.Disconnect;
  end
  else
  begin
    try
      ClientSend.Connect;
    except
      on E: Exception do
      begin
        MemoSend.Lines.Add(E.Message);
      end;
    end;
  end;
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  SendeString := Edit1.Text;
end;

procedure TForm1.ClientReceiveConnected(Sender: TObject);
begin
  TLogReceive.AddMsg('DEBUG: TForm1.clientConnected');
  rt := TReadingThread.Create(ClientReceive);
end;

procedure TForm1.ClientReceiveDisconnected(Sender: TObject);
begin
  TLogReceive.AddMsg('DEBUG: TForm1.clientDisconnected');
  if rt <> nil then
  begin
    rt.Terminate;
    rt.WaitFor;
    FreeAndNil(rt);
  end;
end;

procedure TForm1.ClientSendConnected(Sender: TObject);
begin
  TLogSend.AddMsg('DEBUG: TForm1.clientConnected');
  wt := TWritingThread.Create(ClientSend);
end;

procedure TForm1.ClientSendDisconnected(Sender: TObject);
begin
  TLogSend.AddMsg('DEBUG: TForm1.clientDisconnected');
  if wt <> nil then
  begin
    wt.Terminate;
    wt.WaitFor;
    FreeAndNil(wt);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
ini: TIniFile;
filename: string;
begin
  MemoReceive.Clear;
  marktime(LVdelay);
  filename := ExtractFilePath(ParamStr(0)) + 'KBS.ini';
  ini := TIniFile.Create(filename);
  try

  finally
  ini.Free;
  end;

end;

function LichtSteuern(WelchesLicht: string; ObenFarbe: string;
  ObenLicht: Integer; UntenFarbe: string; UntenLicht: Integer): string;
begin

end;

end.

Ich bin jetzt auch wieder am Entwicklungssystem und kann jetzt Sachen testen.

Hallo,

leider kann ich mich im Moment noch nicht mit Deinem Code beschäftigen. Ich schaue ihn mir später noch genauer an.

Einige Fragen vorweg:
Warum arbeitest Du mit zwei "Thread-Clients"?
Bekommst Du vom Server immer nur eine Antwort, wenn Du eine Clientanfrage an den Server sendest oder sendet der
Server auch "ungefragt" Text an den Client?

Ich kenne mich mit KBS Pick-by-light Systemen leider nicht aus.