I have been struggling to send/receive TVideoCaptureDevice Live Stream to Client-Server-Client. I am using TIdTCPServer and TIdTCPClient. When try to receive I am getting Connection closed Gracefully. How to overcome the Connection closed gracefully?
Below is my code:
Server
//for send
procedure TWebSocket.videoSendServerExecute(AContext: TIdContext);
var
fip: string;
ms: TMemoryStream;
cmd: string;
begin
cmd := AContext.Connection.IOHandler.ReadLn(IndyTextEncoding_UTF8);
if AContext.Connection.Connected then
begin
fip := cmd;//AContext.Connection.Socket.Binding.PeerIP;
fip := Copy(fip, Pos(':', fip) + 1, Length(fip));
ms := vWebcamCollection.GetItem(vWebcamCollection.GetIndexByIP(fip)).StartedStream;
ms.Position := 0;
AContext.Connection.IOHandler.LargeStream := True;
AContext.Connection.IOHandler.ReadStream(ms);
AContext.Connection.IOHandler.WriteLn('DONE', IndyTextEncoding_UTF8);
end;
end;
//for receive
procedure TWebSocket.videoReceiveServerExecute(AContext: TIdContext);
var
ms: TMemoryStream;
cmd, viewip: string;
begin
cmd := AContext.Connection.IOHandler.ReadLn;
viewip := cmd;
viewip := Copy(viewip, Pos(':', viewip) + 1, Length(viewip));
ms := vWebcamCollection.GetItem(vWebcamCollection.GetIndexByIP(viewip)).StartedStream;
ms.Position := 0;
AContext.Connection.IOHandler.LargeStream := True;
AContext.Connection.IOHandler.Write(ms, 0, True);
AContext.Connection.IOHandler.WriteLn('DONE', IndyTextEncoding_UTF8);
end;
Client
both timers interval is 500
//for sending stream in TTimer.OnTimer
procedure TfrmVideoForm.sendTimerTimer(Sender: TObject);
begin
sendTimer.Enabled := False;
TThread.Synchronize(TThread.CurrentThread, (
procedure
var
aIp: String;
ms: TMemoryStream;
begin
aIp := getLocalIPAddress;
aIp := Format('send:%s', [aIp]);
videoClient.IOHandler.WriteLn(aIp, IndyTextEncoding_UTF8);
ms := TMemoryStream.Create;
videoClient.IOHandler.LargeStream := True;
imgVideo.Bitmap.SaveToStream(ms);
ms.Position := 0;
videoClient.IOHandler.Write(ms, 0, True);
videoClient.IOHandler.ReadLn(IndyTextEncoding_UTF8);
end));
sendTimer.Enabled := True;
end;
//for receiving stream - fIPAddress = which IPAddress Start TVideoCaptureDevice
procedure TfrmVideoForm.receiveTimerTimer(Sender: TObject);
begin
receiveTimer.Enabled := False;
TThread.Synchronize(TThread.CurrentThread, (
procedure
var
strm: TMemoryStream;
begin
videoRcvClient.IOHandler.WriteLn('receive:' + fIPAddress,
IndyTextEncoding_UTF8);
strm := TMemoryStream.Create;
videoRcvClient.IOHandler.LargeStream := True;
videoRcvClient.IOHandler.ReadStream(strm);
videoRcvClient.IOHandler.ReadLn(IndyTextEncoding_UTF8);
strm.Position := 0;
imgVideo.Bitmap.LoadFromStream(strm);
strm.Free;
end));
receiveTimer.Enabled := True;
end;
code for server holding IPAdress
{ TWebcamItem }
TWebcamItem = class(TCollectionItem)
private
fStartedIP: string;
fStartedStream: TMemoryStream;
public
procedure Assign(Source: TPersistent); override;
constructor Create(ACollection: TCollection); override;
destructor Destroy; override;
property StartedIP: string read fStartedIP write fStartedIP;
property StartedStream: TMemoryStream read fStartedStream write fStartedStream;
procedure CreateStream;
procedure FreeStream;
end;
{ TWebcamCollection }
TWebcamCollection = class(TCollection)
private
function GetItem(Index: integer): TWebcamItem;
procedure SetItem(Index: integer; AValue: TWebcamItem);
public
constructor Create;
function Add: TWebcamItem;
property Items[Index: integer]: TWebcamItem read GetItem write SetItem; default;
function GetIndexByIP(AIP: string): integer;
end;
Related
I have a simple TidTCPServer Working on a console and accepting Data. My problem is when the client Send Stream but having a very high of speed exchange data, The server freeze after 70 lines and the CPU load of the server go to 70%; I don't know how can i resolve without adding a sleep between every send . below an example of Client and Server . Can you help me to resolve this (Server Side) thanks .
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);
function ReceiveStream(AContext: TIdContext;Size:integer; var AStream: TStream);
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;
function TMyApplication.ReceiveStream(AContext: TIdContext; var AStream: TStream)
: Boolean; overload;
var
LSize: LongInt;
begin
Result := True;
try
LSize := AContext.Connection.IOHandler.ReadLongInt();
AContext.Connection.IOHandler.ReadStream(AStream,LSize, False)
AStream.Seek(0,soFromBeginning);
except
Result := False;
end;
end;
procedure TMyApplication.ServerOnExecute(AContext: TIdContext);
var AStream:TMemoryStream;
begin
if (Acontext.Connection.IOHandler.InputBufferIsEmpty) then
begin
TLog.LogMsg('--: '+random(100000).ToString); //After executing Client this line is displayed 70 time and CPU load is from 40 % to 70%
AStream:=TMemoryStream.Create;
try
ReceiveStream(AContext,TStream(AStream));
// .. here we use AStream to execute some stuff
finally
Astream.free;
end;
end;
procedure TMyApplication.ServerOnConnect(AContext: TIdContext);
begin
TLog.LogMsg('connect');
end;
procedure TMyApplication.DoRun;
begin
IdTCPServer := tIdTCPServer.Create;
IdTCPServer.ListenQueue := 15;
IdTCPServer.MaxConnections := 0;
IdTCPServer.TerminateWaitTime := 5000;
with IdTCPServer.Bindings.Add
do begin
IP := '0.0.0.0';
Port := 80;
IPVersion:=Id_IPv4;
end;
IdTCPServer.OnConnect := ServerOnConnect;
IdTCPServer.OnDisconnect := ServerOnDiconnect;
IdTCPServer.OnExecute := ServerOnExecute;
IdTCPServer.Active := True;
while true do
begin
Classes.CheckSynchronize() ;
sleep(10);
end;
readln;
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.
Client
function TForm1.SendStream(AClient: TIdTCPClient; AStream: TStream): Boolean; overload;
var
StreamSize: LongInt;
begin
try
Result := True;
try
AStream.Seek(0,soFromBeginning);
StreamSize := (AStream.Size);
AClient.IOHandler.Write(LongInt(StreamSize));
AClient.IOHandler.WriteBufferOpen;
AClient.IOHandler.Write(AStream, 0, False);
AClient.IOHandler.WriteBufferFlush;
finally
AClient.IOHandler.WriteBufferClose;
end;
except
Result := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Packet:TPacket;
AStream:TMemoryStream;
begin
for i:=0 to 1000 do
begin
Application.ProcessMessages;
With Packet do
begin
MX := random(10000);
MY := random(10000);
end;
AStream:=TMemoryStream.Create;
try
AStream.Write(Packet,SizeOf(TPacket));
SendStream(IdTCPClientCmd,TStream(AStream));
finally
AStream.Free;
end;
end;
end;
On the server side, your InputBufferIsEmpty() check is backwards. If the client is sending a lot of data, InputBufferIsEmpty() is likely to become False eventually, which will cause your server code to enter a tight unyielding loop that doesn't actually read anything. Just get rid of the check entirely and let ReceiveStream() block until there is a packet available to read.
Also, why are you setting the server's ListenQueue to 15, but the MaxConnections to 0? MaxConnections=0 will force the server to immediately close every client connection that is accepted, so the OnExecute event will never get a chance to be called.
On the client side, there is no need to destroy and recreate the TMemoryStream on each loop iteration, you should reuse that object.
But more importantly, you are not using write buffering correctly, so either fix that or get rid of it. I would do the latter, as you are sending lots of small packets, so just let TCP's default coalescing handle the buffering for you.
And TIdIOHandler.Write(TStream)/TIdIOHandler.ReadStream() can exchange the stream size for you, you don't need to do that manually.
Try this instead:
Server
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);
function ReceiveStream(AContext: TIdContext; Size: Integer; var AStream: TStream);
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;
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;
function TMyApplication.ReceiveStream(AContext: TIdContext; AStream: TStream): Boolean; overload;
begin
try
AContext.Connection.IOHandler.ReadStream(AStream, -1, False);
AStream.Position := 0;
Result := True;
except
Result := False;
end;
end;
procedure TMyApplication.ServerOnExecute(AContext: TIdContext);
var
AStream: TMemoryStream;
begin
AStream := TMemoryStream.Create;
try
if not ReceiveStream(AContext, AStream) then
begin
AContext.Connection.Disconnect;
Exit;
end;
TLog.LogMsg('--: '+random(100000).ToString); //After executing Client this line is displayed 70 time and CPU load is from 40 % to 70%
// .. here we use AStream to execute some stuff
finally
AStream.Free;
end;
end;
procedure TMyApplication.ServerOnConnect(AContext: TIdContext);
begin
TLog.LogMsg('connect');
AContext.Connection.IOHandler.LargeStream := False;
end;
procedure TMyApplication.DoRun;
begin
IdTCPServer := TIdTCPServer.Create;
IdTCPServer.ListenQueue := 15;
IdTCPServer.MaxConnections := 1;
IdTCPServer.TerminateWaitTime := 5000;
with IdTCPServer.Bindings.Add do
begin
IP := '0.0.0.0';
Port := 80;
IPVersion := Id_IPv4;
end;
IdTCPServer.OnConnect := ServerOnConnect;
IdTCPServer.OnDisconnect := ServerOnDiconnect;
IdTCPServer.OnExecute := ServerOnExecute;
IdTCPServer.Active := True;
while True do
begin
Classes.CheckSynchronize();
Sleep(10);
end;
ReadLn;
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.
Client
function TForm1.SendStream(AClient: TIdTCPClient; AStream: TStream): Boolean; overload;
begin
try
AClient.IOHandler.LargeStream := False; // <-- or, set this 1 time after TIdTCPClient.Connect() exits...
AClient.IOHandler.Write(AStream, 0, True);
Result := True;
except
Result := False;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Packet: TPacket;
AStream: TMemoryStream;
i: Integer;
begin
AStream := TMemoryStream.Create;
try
AStream.Size := SizeOf(TPacket);
for i := 0 to 1000 do
begin
Application.ProcessMessages;
with Packet do
begin
MX := random(10000);
MY := random(10000);
end;
AStream.Position := 0;
AStream.Write(Packet, SizeOf(TPacket));
SendStream(IdTCPClientCmd, AStream);
end;
finally
AStream.Free;
end;
end;
After some time my client thread stops receiving/sending commands from/to TIdTcpServer.
Here is the client side thread I copied from an example from Remy:
Tested locally and it doesn't happen, only on a running environment the error occurs...
type
TDataEvent = procedure(const LBuffer: TIdBytes) of object;
TReadingThread = class(TThread)
private
FClient : TIdTCPClient;
FData : TIdBytes;
FOnData : TDataEvent;
procedure DataReceived;
protected
procedure Execute; override;
public
constructor Create(AClient: TIdTCPClient); reintroduce;
property OnData: TDataEvent read FOnData write FOnData;
end;
constructor TReadingThread.Create(AClient: TIdTCPClient);
begin
inherited Create(True);
FClient := AClient;
end;
procedure TReadingThread.Execute;
begin
while not Terminated do
begin
Form1.Cliente.IOHandler.ReadBytes(FData, szProtocol, False);
if (FData <> nil) and Assigned(FOnData) then Synchronize(DataReceived);
end;
end;
procedure TReadingThread.DataReceived;
begin
if Assigned(FOnData) then FOnData(FData);
end;
procedure TForm1.DataReceived(const LBuffer: TIdBytes);
type
PTBytes = ^TBytes;
PTIdBytes = ^TIdBytes;
var
LDataSize : Integer;
LProtocol : TProtocol;
LBuffer2 : TBytes;
LProtocol2 : TProtocol;
begin
LProtocol := BytesToProtocol(PTBytes(#LBuffer)^);
case LProtocol.Command of
cmdHWID:
begin
HWID := LProtocol.Sender.HWID;
end;
cmdPing:
begin
InitProtocol(LProtocol2);
LProtocol2.Command := cmdPing;
LProtocol2.Sender.PBack := GetTickCount;
LBuffer2 := ProtocolToBytes(LProtocol2);
Form1.Cliente.IOHandler.Write(PTIdBytes(#LBuffer2)^);
ClearBuffer(LBuffer2);
end;
end;
end;
For a while all works perfectly, but after some time, the client side stops receiving/sending. The connection to the server is seems to be still open.
function to find connection by ip:
list := IdTCPServer1.Contexts.LockList;
try
for i := 0 to list.Count - 1 do
begin
ctx := TIdContext(list[i]);
if ctx.Binding.PeerIP = Edit9.Text then
begin
TLog.AddMsg('IP FOUND');
Achou := True;
Cliente := TClientContext(ctx);
SerialCn := Cliente.Client.HWID;
IpCn := Cliente.Client.IP;
break;
end;
end;
finally
IdTCPServer1.Contexts.UnlockList;
end;
I'm trying to create my own class object and use it to store various data types for my application, this all works fine when using Published Properties, I can stream these to disk and back with no problems. But I need to stream some dynamic Arrays of integer types as well.
type
TArrayOfInteger = array of integer;
TSetting = class(TComponent)
private
fIntVal: integer;
fIntArr: TArrayOfInteger;
procedure ReadIntArr(Reader: TReader);
procedure WriteIntArr(Writer: TWriter);
protected
procedure DefineProperties(Filer: TFiler); override;
published
property intval: integer read fIntVal write fIntVal;
property intArr: TArrayOfInteger read fIntArr write fIntArr;
end;
{ TSetting }
procedure TSetting.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineProperty('intArr', ReadIntArr, WriteIntArr, true);
end;
procedure TSetting.ReadIntArr(Reader: TReader);
var
i: integer;
lvVal:Integer;
begin
i:=low(fintArr);
Reader.ReadListBegin;
{j := Reader.ReadInteger();
setlength(fIntArr, j);
for i := 0 to j - 1 do
begin
fIntArr[i] := Reader.ReadInteger();
end;}
while not Reader.EndOfList do begin
fIntArr[i]:=Reader.ReadInteger;
Inc(i);
end;
Reader.ReadListEnd;
end;
procedure TSetting.WriteIntArr(Writer: TWriter);
var
i: integer;
begin
Writer.WriteListBegin;
//Writer.WriteInteger(integer(Length(fIntArr)));
for i := Low(fIntArr) to High(fIntArr) do
begin
Writer.WriteInteger(fIntArr[i]);
end;
Writer.WriteListEnd;
end;
function ClassToStr(pvClass:TComponent):ansiString;
var
inStream, outStream: TMemoryStream;
begin
inStream := TMemoryStream.Create;
outStream := TMemoryStream.Create;
try
inStream.WriteComponentRes(pvClass.ClassName, pvClass);
//inStream.WriteComponent(pvClass);
inStream.Position := 0;
ObjectResourceToText(inStream, outStream);
// ObjectBinaryToText(inStream,outStream);
outStream.Position := 0;
SetLength(Result,outStream.Size+1);
FillChar(result[1],outStream.Size+1,0);
outStream.ReadBuffer(result[1],outStream.Size);
finally
FreeAndNil(inStream);
FreeAndNil(outStream);
end;
end;
function StrToClass(pvStr:AnsiString;pvComponent:TComponent):tcomponent;
var
inStream, outStream: TMemoryStream;
begin
inStream := TMemoryStream.Create;
outStream := TMemoryStream.Create;
try
if (pvStr<>'') then
inStream.WriteBuffer(pvStr[1],length(pvStr));
inStream.Position:=0;
ObjectTextToResource(inStream, outStream);
// ObjectTextToBinary(inStream,outStream);
outStream.Position:=0;
result:=outStream.ReadComponentRes(pvComponent); //*****Exception Fired*****
//result:=outStream.ReadComponent(pvComponent);
finally
FreeAndNil(inStream);
FreeAndNil(outStream);
end;
end;
=============
//test
procedure TForm1.btn5Click(Sender: TObject);
var
lvObj,lv1: TSetting;
lvStr:String;
lvArr:TArrayOfInteger;
begin
lvObj := TSetting.Create(nil);
try
lvObj.intval := 12345;
setlength(lvArr, 3);
lvArr[0] := 222;
lvArr[1] := 333;
lvArr[2] := 444;
lvObj.intArr:=lvArr;
lvStr:=ClassToStr(lvObj);
RegisterClass(TSetting);
lvObj.intval:=1;
lv1:=TSetting( StrToClass(lvStr,lvObj));
if (lv1.intval>0) then
mmo1.Text:=lvStr;
finally
FreeAndNil(lvObj);
end;
// WriteComponentResFile(ExtractFilePath(ParamStr(0))+ 'd.res',self);
end;
//First chance exception at $77925B68. Exception class EReadError with message 'Property does not exist'. Process Project1.exe (23512)
//First chance exception at $77925B68. Exception class EReadError with message 'Error reading TSetting.: Property does not exist'. Process Project1.exe (23512)
result:=outStream.ReadComponentRes(pvComponent); //*****Exception Fired*****
You are not allocating the array when reading it. You could do that like so:
procedure TSetting.ReadIntArr(Reader: TReader);
begin
fIntArr := nil;
Reader.ReadListBegin;
while not Reader.EndOfList do begin
SetLength(fIntArr, Length(fIntArr) + 1);
fIntArr[high(fIntArr)] := Reader.ReadInteger;
end;
Reader.ReadListEnd;
end;
The other change that you need to make is to move intArr to be a public property. You cannot have it published, and also define a property with the same name in DefineProperties.
I am somewhat dubious of your use of AnsiString. I would have expected UTF-8 encoded bytes in case of non-ASCII characters. Perhaps you should be using a string stream with the appropriate encoding specified.
Personally I am rather sceptical of using form streaming in this way. I would prefer to use a standard format such as JSON.
You are not allocating the array before reading data into it. You were on the right track to have WriteIntArr() save the array length and ReadIntArr() to allocate the array based on that value, so you should re-enable that logic, eg:
type
TArrayOfInteger = array of integer;
TSetting = class(TComponent)
private
fIntVal: integer;
fIntArr: TArrayOfInteger;
procedure ReadIntArr(Reader: TReader);
procedure WriteIntArr(Writer: TWriter);
protected
procedure DefineProperties(Filer: TFiler); override;
public
property intArr: TArrayOfInteger read fIntArr write fIntArr;
published
property intval: integer read fIntVal write fIntVal;
end;
{ TSetting }
procedure TSetting.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineProperty('intArr', ReadIntArr, WriteIntArr, true);
end;
procedure TSetting.ReadIntArr(Reader: TReader);
var
i: integer;
begin
i := Reader.ReadInteger;
SetLength(fIntArr, i);
for i := Low(fIntArr) to High(fIntArr) do
fIntArr[i] := Reader.ReadInteger;
end;
procedure TSetting.WriteIntArr(Writer: TWriter);
var
i: integer;
begin
Writer.WriteInteger(Length(fIntArr));
for i := Low(fIntArr) to High(fIntArr) do
Writer.WriteInteger(fIntArr[i]);
end;
Alternatively:
type
TArrayOfInteger = array of integer;
TSetting = class(TComponent)
private
fIntVal: integer;
fIntArr: TArrayOfInteger;
procedure ReadIntArr(Stream: TStream);
procedure WriteIntArr(Stream: TStream);
protected
procedure DefineProperties(Filer: TFiler); override;
public
property intArr: TArrayOfInteger read fIntArr write fIntArr;
published
property intval: integer read fIntVal write fIntVal;
end;
{ TSetting }
procedure TSetting.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineBinaryProperty('intArr', ReadIntArr, WriteIntArr, true);
end;
procedure TSetting.ReadIntArr(Stream: TStream);
var
i: integer;
begin
Stream.ReadBuffer(i, SizeOf(Integer));
SetLength(fIntArr, i);
for i := Low(fIntArr) to High(fIntArr) do
Stream.ReadBuffer(fIntArr[i], SizeOf(Integer));
end;
procedure TSetting.WriteIntArr(Stream: TStream);
var
i: integer;
begin
i := Length(fIntArr);
Stream.WriteBuffer(i, SizeOf(Integer));
for i := Low(fIntArr) to High(fIntArr) do
Stream.WriteBuffer(fIntArr[i], SizeOf(Integer));
end;
I modified the source, it give a demon that how to clone a user class and clone a form . It worked.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TArrayOfInteger = array of integer;
TSetting = class(TComponent)
private
fIntVal: integer;
fIntArr: TArrayOfInteger;
procedure ReadIntArr(Reader: TReader);
procedure WriteIntArr(Writer: TWriter);
protected
procedure DefineProperties(Filer: TFiler); override;
public
property intArr: TArrayOfInteger read fIntArr write fIntArr;
published
property intval: integer read fIntVal write fIntVal;
end;
TForm1 = class(TForm)
btnCloneClass: TButton;
mmo1: TMemo;
btnCloneForm: TButton;
procedure btnCloneClassClick(Sender: TObject);
procedure btnCloneFormClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TSetting }
procedure TSetting.DefineProperties(Filer: TFiler);
begin
inherited;
Filer.DefineProperty('intArr', ReadIntArr, WriteIntArr, true);
end;
procedure TSetting.ReadIntArr(Reader: TReader);
var
lvIdx: integer;
begin
fIntArr := nil;
Reader.ReadListBegin;
SetLength(fIntArr,Reader.ReadInteger);
lvIdx:=low(fIntArr);
while not Reader.EndOfList do
begin
fIntArr[lvIdx] := Reader.ReadInteger;
inc(lvIdx);
end;
Reader.ReadListEnd;
end;
procedure TSetting.WriteIntArr(Writer: TWriter);
var
i: integer;
begin
Writer.WriteListBegin;
Writer.WriteInteger(integer(Length(fIntArr)));
for i := Low(fIntArr) to High(fIntArr) do
begin
Writer.WriteInteger(fIntArr[i]);
end;
Writer.WriteListEnd;
end;
function ClassToStr(pvClass: TComponent): ansiString;
var
inStream, outStream: TMemoryStream;
begin
inStream := TMemoryStream.Create;
outStream := TMemoryStream.Create;
try
inStream.WriteComponentRes(pvClass.ClassName, pvClass);
// inStream.WriteComponent(pvClass);
inStream.Position := 0;
ObjectResourceToText(inStream, outStream);
// ObjectBinaryToText(inStream,outStream);
outStream.Position := 0;
SetLength(Result, outStream.Size + 1);
FillChar(Result[1], outStream.Size + 1, 0);
outStream.ReadBuffer(Result[1], outStream.Size);
finally
FreeAndNil(inStream);
FreeAndNil(outStream);
end;
end;
function StrToClass(pvStr: ansiString; pvCmpToSetProperties: TComponent=nil): TComponent;
var
inStream, outStream: TMemoryStream;
begin
inStream := TMemoryStream.Create;
outStream := TMemoryStream.Create;
try
if (pvStr <> '') then
inStream.WriteBuffer(pvStr[1], length(pvStr));
inStream.Position := 0;
ObjectTextToResource(inStream, outStream);
// ObjectTextToBinary(inStream,outStream);
outStream.Position := 0;
Result := outStream.ReadComponentRes(pvCmpToSetProperties);
finally
FreeAndNil(inStream);
FreeAndNil(outStream);
end;
end;
procedure TForm1.btnCloneClassClick(Sender: TObject);
var
lvObj, lv1: TSetting;
lvStr: String;
lvArr: TArrayOfInteger;
begin
lvObj := TSetting.Create(nil);
try
lvObj.intval := 12345;
SetLength(lvArr, 3);
lvArr[0] := 222;
lvArr[1] := 333;
lvArr[2] := 444;
lvObj.intArr := lvArr;
lvStr := ClassToStr(lvObj);
RegisterClass(TSetting);
lvObj.intval := 1;
lv1 := TSetting(StrToClass(lvStr, nil));
if (lv1.intval > lvObj.intval) then
mmo1.Text := lvStr;
finally
FreeAndNil(lvObj);
FreeAndNil(lv1);
end;
// WriteComponentResFile(ExtractFilePath(ParamStr(0))+ 'd.res',self);
end;
procedure TForm1.btnCloneFormClick(Sender: TObject);
var lvNewForm:TForm1;
lvRes:string;
begin
lvRes:=ClassToStr(self);
RegisterClass(TForm1);
lvNewForm:=TForm1.CreateNew(application);
StrToClass(lvRes,lvNewForm);
lvNewForm.Left:=self.Left+50;
lvNewForm.Top:=self.Top+50;
end;
end.
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 7 years ago.
Improve this question
I am trying to compile my program but I am getting this error:
Undeclared indentifier 'StreamLn'
i even tried to download PSock.dcu and put it into the library but it doesnt compile, it looks like its compactible with delphi 5,
unit ResourceInfo;
interface
uses
Classes, SysUtils, Windows;
type
TResourceInfo = class;
TDfmMode = ( dfmData, dfmResource, dfmASCII, dfmBinary);
TDfm = class
private
FOwner: TResourceInfo;
FName: string;
FData: TStream;
procedure SetName(const Value: string);
procedure SetOwner(const Value: TResourceInfo);
public
constructor Create(AOwner: TResourceInfo);
destructor Destroy; override;
function SaveToFile(FileName: TFileName; Mode: TDfmMode): Boolean;
property Data: TStream read FData;
property Name: string read FName write SetName;
property Owner: TResourceInfo read FOwner write FOwner;
end; {TDfm}
TResourceInfo = class(TComponent)
private
FActive: Boolean;
FDfms: TList;
FExeFileName: TFileName;
FModule: THandle;
FOnActivate: TNotifyEvent;
FOnDeactivate: TNotifyEvent;
procedure SetExeFileName(const Value: TFileName);
procedure SetActive(const Value: Boolean);
function GetDfms(Index: Cardinal): TDfm;
function GetDfmCount: Cardinal;
protected
procedure Clear;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function AddDfm(const Name: string; AData: TMemoryStream): Integer;
procedure DeleteDfm(const Name: string);
property DfmCount: Cardinal read GetDfmCount;
property Dfms[Index: Cardinal]: TDfm read GetDfms;
procedure EnumDfmNames;
property Module: THandle read FModule;
published
property Active: Boolean read FActive write SetActive;
property ExeFileName: TFileName read FExeFileName write SetExeFileName;
property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
end; {TResourceInfo}
procedure Register;
implementation
uses
Winsock;
resourcestring
rsErrorLoadingExeFile = 'An error ocurred loading file %s, it may not be an executable module';
procedure Register;
begin
RegisterComponents('+HCU', [TResourceInfo]);
end; {Register}
{ TResourceInfo }
function TResourceInfo.AddDfm(const Name: string; AData: TMemoryStream): Integer;
var
FDfm: TDfm;
begin
FDfm := TDfm.Create(Self);
FDfm.Name := Name;
FDfm.Data.Size := AData.Size;
FDfm.Data.Seek(0, 0);
AData.Seek(0, 0);
FDfm.Data.CopyFrom(AData, AData.Size);
Result := FDfms.Add(FDfm);
end; {TResourceInfo.AddDfm}
constructor TResourceInfo.Create(AOwner: TComponent);
begin
inherited;
FActive := False;
FDfms := TList.Create;
FModule := 0;
end; {TResourceInfo.Create}
destructor TResourceInfo.Destroy;
begin
Clear;
FDfms.Free;
inherited;
end; {TResourceInfo.Destroy}
function CB_EnumDfmNameProc(hModule: THandle; lpszType, lpszName: PChar; lParam: Integer): Boolean; stdcall;
var
ms: TMemoryStream;
rs: TResourceStream;
Buffer: array of Byte;
begin
with TResourceInfo(lParam) do
begin
rs := TResourceStream.Create(TResourceInfo(lParam).Module, lpszname, lpszType);
try
ms := TMemoryStream.Create;
try
try
SetLength(Buffer, 4);
rs.Read(Buffer[0], SizeOf(Buffer));
if string(Buffer) = 'TPF0' then
begin
rs.Seek(0, 0);
ObjectBinaryToText(rs, ms);
ms.Seek(0, 0);
AddDfm(StrPas(lpszName), ms);
end;
except
raise;
end;
finally
ms.Free;
end;
finally
rs.free;
end;
end;
Result := True;
end; {CB_EnumDfmNameProc}
procedure TResourceInfo.EnumDfmNames;
begin
if FModule > 0 then
EnumResourceNames(FModule, RT_RCDATA, #CB_EnumDfmNameProc, Integer(Self));
end; {TResourceInfo.EnumDfmNames}
procedure TResourceInfo.DeleteDfm(const Name: string);
var
i: Cardinal;
begin
if FDfms.Count > 0 then
for i := Pred(FDfms.Count) downto 0 do
if UpperCase(TDfm(FDfms[i]).Name) = UpperCase(Name) then
begin
FDfms.Delete(i);
Break;
end;
end; {TResourceInfo.DeleteDfm}
procedure TResourceInfo.SetActive(const Value: Boolean);
begin
if FActive <> Value then
begin
if Value then
begin
if FModule > 0 then
FreeLibrary(FModule);
(* LOAD_LIBRARY_AS_DATAFILE
If this value is given, the function does a simple mapping of the file into the
address space. Nothing is done relative to executing or preparing to execute the
code in the mapped file. The function loads the module as if it were a data file.
You can use the module handle that the function returns in this case with the Win32
functions that operate on resources. Use this flag when you want to load a DLL in
order to extract messages or resources from it, and have no intention of executing
its code.If this value is not given, the function maps the file into the address
space in the manner that is normal for an executable module. The behavior of the
function is then identical to that of LoadLibrary in this regard. *)
FModule := LoadLibraryEx(PChar(FExeFileName), 0, LOAD_LIBRARY_AS_DATAFILE);
if not (FModule >= 32) then
raise Exception.CreateFmt(rsErrorLoadingExeFile, [FExeFileName]);
if Assigned(FOnActivate) then
FOnActivate(Self);
end
else
begin
Clear;
if FModule > 0 then
begin
FreeLibrary(FModule);
FModule := 0;
end;
if Assigned(FOnDeactivate) then
FOnDeactivate(Self);
end;
FActive := Value;
end;
end; {TResourceInfo.SetActive}
procedure TResourceInfo.SetExeFileName(const Value: TFileName);
begin
if FExeFileName <> Value then
FExeFileName := Value;
end; {TResourceInfo.SetExeFileName}
function TResourceInfo.GetDfms(Index: Cardinal): TDfm;
begin
Result := TDfm(FDfms[Index]);
end; {TResourceInfo.GetDfms}
function TResourceInfo.GetDfmCount: Cardinal;
begin
Result := FDfms.Count;
end; {TResourceInfo.GetDfmCount}
procedure TResourceInfo.Clear;
begin
if FDfms.Count > 0 then
while FDfms.Count > 0 do
FDfms.Delete(0);
end; {TResourceInfo.Clear}
{ TDfm }
constructor TDfm.Create(AOwner: TResourceInfo);
begin
inherited Create;
FData := TMemoryStream.Create;
FName := '';
SetOwner(AOwner);
end; {TDfm.Create}
destructor TDfm.Destroy;
begin
FData.Free;
inherited;
end; {TDfm.Destroy}
function TDfm.SaveToFile(FileName: TFileName; Mode: TDfmMode): Boolean;
function EndOfStream(Stream: TStream): Boolean;
begin
with Stream do
Result := Position = Size;
end; {EndOfStream}
var
fs: TFileStream;
ms: TMemoryStream;
s: string;
i, j: Byte;
begin
fs := TFileStream.Create(FileName, fmCreate or fmShareExclusive);
try
FData.Seek(0, 0);
case Mode of
dfmASCII:
begin
ms := TMemoryStream.Create;
try
s := FName + ' RCDATA' + #13#10 + '{';
StreamLN(fs, s);
ObjectTextToBinary(FData, ms);
ms.Seek(0, 0);
while not EndOfStream(ms) do
begin
s := '''';
for i := 0 to 15 do
begin
if ms.Read(j, SizeOf(j)) = 0 then
Break;
s := Concat(s, Format('%2.2x', [j]));
if (i = 15) or EndOfStream(ms) then
s := Concat(s, '''')
else
s := Concat(s, ' ');
end;
if EndOfStream(ms) then
s := Concat(s, #13#10 + '}');
StreamLN(fs, s);
end;
finally
ms.Free;
end;
end;
dfmBinary:
ObjectTextToBinary(FData, fs);
end;
finally
fs.Free;
end;
end; {TDfm.SaveToFile}
procedure TDfm.SetName(const Value: string);
begin
if FName <> Value then
FName := Value;
end; {TDfm.SetName}
procedure TDfm.SetOwner(const Value: TResourceInfo);
begin
FOwner := Value;
end; {TDfm.SetOwner}
end.
How can I declare it successfully?
Appears to me that WinSock unit does not have an StreamLn function (as PowerSock's PSock.pas unit uses Winsock as imported unit).
The StreamLn function in PSock.pas just adds an CRLF sequence to the string passed as parameter before calling the TStream.WriteBuffer method of the passed TStream parameter.
Here's the google cache snapshot from the Powersock's source code of PSock.pas
You need to either implement this function, or add a unit where this function is declared to your uses section.
I'm trying to get a screenshot and send it over the web using ClientSocket and ServerSocket components.
I'm having problems when I try to turn the stream received at ServerSocket into a picture again. Error message "Bitmap Image is not valid!" when performing:
DesktopForm.imgScreen.Picture.Bitmap.LoadFromStream(ms);
I do not know if the problem is in the way sending the image or get in the way.
My server code:
unit UntThreadDesktop;
interface
uses
System.Classes,
System.SysUtils,
System.Win.ScktComp,
WinApi.Windows,
WinApi.ActiveX,
Vcl.Graphics,
Vcl.Imaging.Jpeg,
UntDesktopForm;
type
TThreadDesktop = class(TThread)
private
FSocket: TCustomWinSocket;
FDesktopForm: TDesktopForm;
public
constructor Create(ASocket: TCustomWinSocket);
destructor Destroy; override;
procedure Execute; override;
end;
implementation
uses
UntLibraries;
{ TThreadDesktop }
constructor TThreadDesktop.Create(ASocket: TCustomWinSocket);
begin
inherited Create(true);
FreeOnTerminate := true;
FSocket := ASocket;
end;
destructor TThreadDesktop.Destroy;
begin
inherited;
end;
procedure TThreadDesktop.Execute;
var
text: string;
fileSize: integer;
ms: TMemoryStream;
buf: Pointer;
nBytes: integer;
jpg: TJPEGImage;
begin
inherited;
CoInitialize(nil);
try
// Init DesktopForm
Synchronize(procedure begin
FDesktopForm := TDesktopForm.Create;
FDesktopForm.Show;
end);
ms := TMemoryStream.Create;
try
FSocket.SendText('<|GetScreen|>');
while FSocket.Connected and (not Self.Terminated) and (FDesktopForm <> nil) do
begin
if FSocket.ReceiveLength > 0 then
begin
ms.Clear;
text := string(FSocket.ReceiveText);
text := Copy(text,1, Pos(#0,text)-1);
fileSize := StrToInt(text);
// Receiving file
while FSocket.Connected and (not Self.Terminated) and (FDesktopForm <> nil) do
begin
Synchronize(procedure begin
if FDesktopForm <> nil then
FDesktopForm.panInfo.Caption := 'Total: ' + IntToStr(ms.Size) +
' de ' + IntToStr(fileSize);
end);
try
text := '';
GetMem(buf, FSocket.ReceiveLength);
try
nBytes := FSocket.ReceiveBuf(buf^, FSocket.ReceiveLength);
if nBytes > 0 then
ms.Write(buf^, nBytes);
if (ms.Size = fileSize) or (nBytes <= 0) then
begin
ms.Position := 0;
ms.SaveToFile('C:\Temp\Screen.bmp');
ms.Position := 0;
//jpg := TJPEGImage.Create;
//jpg.LoadFromStream(ms);
// Carrega a imagem
Synchronize(procedure begin
if FDesktopForm <> nil then
//FDesktopForm.imgScreen.Picture.Assign(jpg);
FDesktopForm.imgScreen.Picture.Graphic.LoadFromStream(ms);
end);
end;
finally
FreeMem(buf);
end;
except
end;
end;
end;
TThread.Sleep(10);
end;
finally
ms.Free;
// Close DesktopForm
Synchronize(procedure begin
if FDesktopForm <> nil then
FDesktopForm.Close;
end);
end;
finally
CoUninitialize;
end;
end;
end.
It´s a thread used to receive the image in background.
In the main form of my application server I own a TServerSocket component working with the ServerType property to stThreadBlocking.
In my client application I have TClientSocket component using the property ClientType as ctNonBlocking.
My thread code:
unit UntThreadDesktopClient;
interface
uses
System.Classes,
System.SysUtils,
System.Win.ScktComp,
WinApi.Windows,
WinApi.ActiveX,
Vcl.Imaging.Jpeg,
Vcl.Graphics,
Vcl.Forms;
type
TThreadDesktopClient = class(TThread)
private
FSocket: TClientSocket;
FStream: TMemoryStream;
public
constructor Create(AHostname: string; APort: integer); reintroduce;
destructor Destroy; override;
procedure Execute; override;
private
procedure OnConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure GetScreen(stream: TMemoryStream);
end;
implementation
{ TThreadDesktopClient }
constructor TThreadDesktopClient.Create(AHostname: string; APort: integer);
begin
inherited Create(true);
FreeOnTerminate := true;
FStream := TMemoryStream.Create;
FSocket := TClientSocket.Create(nil);
FSocket.ClientType := ctNonBlocking;
FSocket.Host := AHostname;
FSocket.Port := APort;
FSocket.OnConnect := OnConnect;
FSocket.Open;
end;
destructor TThreadDesktopClient.Destroy;
begin
FStream.Free;
if FSocket.Active then
FSocket.Close;
FSocket.Free;
inherited;
end;
procedure TThreadDesktopClient.Execute;
var
cmd: AnsiString;
begin
inherited;
CoInitialize(nil);
try
while FSocket.Active and not Self.Terminated do
begin
if FSocket.Socket.ReceiveLength > 0 then
begin
cmd := FSocket.Socket.ReceiveText;
if cmd = '<|GetScreen|>' then
begin
FStream.Clear;
GetScreen(FStream);
FStream.Position := 0;
FSocket.Socket.SendText(AnsiString(IntToStr(FStream.Size)) + #0);
FSocket.Socket.SendStream(FStream);
end
else
if cmd = '<|TYPE|>' then
begin
FSocket.Socket.SendText('<|TYPE-DESKTOP|>');
end;
end;
end;
finally
CoUninitialize;
end;
end;
procedure TThreadDesktopClient.OnConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Start;
end;
procedure TThreadDesktopClient.GetScreen(stream: TMemoryStream);
var
DC: HDC;
bmp: TBitmap;
jpg: TJPEGImage;
begin
DC := GetDC(GetDesktopWindow);
try
bmp := TBitmap.Create;
jpg := TJPEGImage.Create;
try
//bmp.PixelFormat := pf8bit;
bmp.Width := GetDeviceCaps(DC, HORZRES);
bmp.Height := GetDeviceCaps(DC, VERTRES);
//bmp.Width := Screen.Width;
//bmp.Height := Screen.Height;
BitBlt(bmp.Canvas.Handle, 0, 0, bmp.Width, bmp.Height, DC, 0, 0, SRCCOPY);
bmp.Modified := True;
//jpg.Assign(bmp);
//jpg.Compress;
stream.Clear;
//jpg.SaveToStream(stream);
bmp.SaveToStream(stream);
finally
bmp.Free;
jpg.Free;
end;
finally
ReleaseDC(GetDesktopWindow, DC);
end;
end;
end.
For further clarification, I will also post my main thread of the client application and how it is called in the main form from my client application.
unit UntThreadMain;
interface
uses
System.Classes,
System.Win.ScktComp,
WinApi.ActiveX;
type
TThreadMain = class(TThread)
private
FClientSocket: TClientSocket;
public
constructor Create(AHostname: string; APort: integer); reintroduce;
destructor Destroy; override;
procedure Execute; override;
public
procedure OnConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure OnDisconnect(Sender: TObject; Socket: TCustomWinSocket);
procedure OnError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
private
procedure SendInfo;
procedure OpenDesktopChannel;
end;
implementation
uses
UntClientMainForm,
UntThreadDesktopClient;
{ TThreadMain }
constructor TThreadMain.Create(AHostname: string; APort: integer);
begin
inherited Create(true);
FreeOnTerminate := false;
FClientSocket := TClientSocket.Create(nil);
FClientSocket.ClientType := ctNonBlocking;
FClientSocket.Host := AHostname;
FClientSocket.Port := APort;
FClientSocket.OnConnect := OnConnect;
FClientSocket.OnDisconnect := OnDisconnect;
FClientSocket.Open;
end;
destructor TThreadMain.Destroy;
begin
if FClientSocket.Active then
FClientSocket.Close;
FClientSocket.Free;
inherited;
end;
procedure TThreadMain.Execute;
var
cmd: AnsiString;
begin
inherited;
CoInitialize(nil);
try
while FClientSocket.Socket.Connected and not Self.Terminated do
begin
if FClientSocket.Socket.ReceiveLength > 0 then
begin
cmd := FClientSocket.Socket.ReceiveText;
if cmd = '<|TYPE|>' then
FClientSocket.Socket.SendText('<|TYPE-COMMAND|>')
else
if cmd = '<|INFO|>' then
SendInfo
else
if cmd = '<|REQUEST-DESKTOP|>' then
TThreadDesktopClient.Create(FClientSocket.Host, FClientSocket.Port);
end;
end;
finally
CoUninitialize;
end;
end;
procedure TThreadMain.OnConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Start;
Synchronize(procedure
begin
ClientMainForm.stBar.Panels[1].Text := 'Conectado';
ClientMainForm.btnConectar.Caption := 'Desconectar';
end);
end;
procedure TThreadMain.OnDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Synchronize(procedure
begin
ClientMainForm.stBar.Panels[1].Text := 'Desconectado';
ClientMainForm.btnConectar.Caption := 'Conectar';
end);
end;
procedure TThreadMain.OnError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
ErrorCode := 0;
end;
procedure TThreadMain.SendInfo;
var
cmd: AnsiString;
begin
cmd := '<|INFO|>;NomePC=Tiago-PC;SO=Windows Seven Professiona 64-bit;' +
'CPU=Intel Core i7 3ª Geração';
FClientSocket.Socket.SendText(cmd);
end;
end.
Note that this thread calls the TThreadDesktopClient.
In the main form of the application server, where the TServerSocket, got OnGetThread TServerSocket the method this way:
procedure TMainForm.ServerSocketGetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket; var SocketThread: TServerClientThread);
begin
SocketThread := TThreadController.Create(false, ClientSocket);
end;
When an image is requested:
procedure TMainForm.pmiAcessarClick(Sender: TObject);
var
nI: integer;
begin
for nI := 0 to Pred(ServerSocket.Socket.ActiveConnections) do
begin
if ServerSocket.Socket.Connections[nI].SocketHandle = cdsClientesId.AsInteger then
ServerSocket.Socket.Connections[nI].SendText('<|REQUEST-DESKTOP|>');
end;
end;
Returning to my client application, this code is used to connect in server (TServerSocket).
procedure TClientMainForm.btnConectarClick(Sender: TObject);
begin
if FThreadMain = nil then
begin
FThreadMain := TThreadMain.Create('localhost', 6550);
end
else
begin
FThreadMain.Terminate;
FThreadMain.Free;
FThreadMain := nil;
end;
end;
So, this is all my code.
When an image is received, I try to load it on TImage get the error message: "Bitmap Image is not valid."
I've tried a few different ways to treat the stream sent by the client application. But it still fails.
Usually got the same error: "Bitmap Image is not valid."
There are a LOT of problems with the code you showed - ranging from a fundamental lack of understanding of how TClientSocket and TServerSocket actually work in general, to a lack of understanding of how to send/receive/parse over TCP/IP. I see very few things in your code that are correct.
You are creating multiple connections on the client side, making each one identify its type (command vs desktop), but your server code is not querying that type or even caring what the type is. It assumes every client is a desktop client and asks for its screen. So you can simplify your code on both sides by simply eliminating that second connection. It is not really needed anyway. You would keep your connections to a minimum to reduce overhead.
I would strongly suggest a re-write of your code.
Try something more like this instead:
Common:
unit UntSocketCommon;
uses
System.Classes,
System.Win.ScktComp;
interface
procedure ReadRawFromSocket(Socket: TWinSocketStream; Buf: Pointer; BufLen: Integer);
function ReadLineFromSocket(Socket: TWinSocketStream): String;
function ReadIntegerFromSocket(Socket: TWinSocketStream): Integer;
procedure ReadStreamFromSocket(Socket: TWinSocketStream; Stream: TStream);
procedure WriteRawFromSocket(Socket: TWinSocketStream; Buf: Pointer; BufLen: Integer);
procedure WriteLineToSocket(Socket: TWinSocketStream; const Value: String);
procedure WriteIntegerToSocket(Socket: TWinSocketStream; Value: Integer);
procedure WriteStreamToSocket(Socket: TWinSocketStream; Stream: TStream);
implementation
procedure ReadRawFromSocket(Socket: TWinSocketStream; Buf: Pointer; BufLen: Integer);
var
PBuf: PByte;
nBytesRead: Integer;
begin
PBuf := PByte(Buf);
while BufLen > 0 do
begin
nBytesRead := Socket.Read(PBuf^, BufLen);
if nBytesRead < 1 then raise Exception.Create('Unable to read from socket');
Inc(PBuf, nBytesRead);
Dec(BufLen, nBytesRead);
end;
end;
function ReadLineFromSocket(Socket: TWinSocketStream): String;
var
Ch: AnsiChar;
Buf: array[0..255] of AnsiChar;
BufLen: Integer;
S: UTF8String;
procedure AppendBuf;
var
OldLen: Integer;
begin
OldLen := Length(S);
SetLength(S, OldLen + BufLen);
Move(Buf[0], S[OldLen], BufLen);
end;
begin
Result := '';
BufLen := 0;
repeat
ReadRawFromSocket(Socket, #Ch, SizeOf(Ch));
if Ch = #10 then Break;
if BufLen = Length(Buf) then
begin
AppendBuf;
BufLen := 0;
end;
Buf[BufLen] := Ch;
Inc(BufLen);
until False;
if BufLen > 0 then AppendBuf;
BufLen := Length(S);
if BufLen > 0 then
begin
if S[BufLen] = #13 then
SetLength(S, BufLen-1);
end;
Result := String(S);
end;
function ReadIntegerFromSocket(Socket: TWinSocketStream): Integer;
begin
ReadRawFromSocket(Socket, #Result, SizeOf(Result));
Result := ntohl(Result);
end;
procedure ReadStreamFromSocket(Socket: TWinSocketStream; Stream: TStream);
var
Size: Integer;
Buf: array[0..1023] of Byte;
nBytes: Integer;
begin
Size := ReadIntegerFromSocket(Socket);
while Size > 0 do
begin
nBytes := Size;
if nBytes > Length(Buf) then nBytes := Length(Buf);
ReadRawFromSocket(Socket, Buf[0], nBytes);
Stream.WriteBuffer(Buf[0], nBytes);
Dec(Size, nBytes);
end;
end;
procedure WriteRawToSocket(Socket: TWinSocketStream; Buf: Pointer; BufLen: Integer);
var
PBuf: PByte;
nBytesWritten: Integer;
begin
PBuf := PByte(Buf);
while BufLen > 0 do
begin
nBytesWritten := Socket.Write(PBuf^, BufLen);
if nBytesWritten < 1 then raise Exception.Create('Unable to write to socket');
Inc(PBuf, nBytesWritten);
Dec(BufLen, nBytesWritten);
end;
end;
procedure WriteLineToSocket(Socket: TWinSocketStream; const Value: String);
var
S: UTF8String;
begin
S := UTF8String(Value + #13#10);
WriteRawToSocket(Socket, PAnsiChar(S), Length(S));
end;
procedure WriteIntegerToSocket(Socket: TWinSocketStream; Value: Integer);
begin
Value := htonl(Value);
WriteRawToSocket(Socket, #Value, SizeOf(Value));
end;
procedure WriteStreamToSocket(Socket: TWinSocketStream; Stream: TStream);
var
Size: Integer;
Buf: array[0..1023] of Byte;
nBytes: Integer;
begin
Size := Stream.Size - Stream.Position;
WriteIntegerToSocket(Socket, Size);
while Size > 0 do
begin
nBytes := Size;
if nBytes > Length(Buf) then nBytes := Length(Buf);
Stream.ReadBuffer(Buf[0], nBytes);
WriteRawToSocket(Socket, Buf[0], nBytes);
Dec(Size, nBytes);
end;
end;
end.
Server:
unit UntThreadDesktop;
interface
uses
System.Classes,
System.Win.ScktComp,
UntDesktopForm;
type
TThreadController = class(TServerClientThread)
private
FDesktopForm: TDesktopForm;
protected
procedure ClientExecute; override;
end;
implementation
uses
System.SysUtils,
WinApi.Windows,
Vcl.Graphics,
UntLibraries,
UntSocketCommon;
{ TThreadDesktop }
procedure TThreadController.ClientExecute;
var
fileSize: Integer;
ms: TMemoryStream;
buf: array[0..1023] of Byte;
nBytes: Integer;
SocketStrm: TWinSocketStream;
begin
SocketStrm := TWinSocketStream.Create(ClientSocket, 5000);
try
// Init DesktopForm
Synchronize(
procedure
begin
FDesktopForm := TDesktopForm.Create;
FDesktopForm.Show;
end
);
try
ms := TMemoryStream.Create;
try
while ClientSocket.Connected and (not Terminated) and (FDesktopForm <> nil) do
begin
ms.Clear;
WriteLineToSocket(SocketStrm, '<|GetScreen|>');
{
ReadStreamFromSocket(SocketStrm, ms);
ms.Position := 0;
ms.SaveToFile('C:\Temp\Screen.bmp');
ms.Position := 0;
Synchronize(
procedure
begin
if FDesktopForm <> nil then
FDesktopForm.imgScreen.Picture.Bitmap.LoadFromStream(ms);
end
);
}
fileSize := ReadIntegerFromSocket(SocketStrm);
while (ms.Size < fileSize) and ClientSocket.Connected and (not Terminated) and (FDesktopForm <> nil) do
begin
Synchronize(
procedure
begin
if FDesktopForm <> nil then
FDesktopForm.panInfo.Caption := 'Total: ' + IntToStr(ms.Size) + ' de ' + IntToStr(fileSize);
end
);
nBytes := fileSize - ms.Size;
if nBytes > Length(Buf) then nBytes := Length(Buf);
ReadRawFromSocket(SocketStrm, buf[0], nBytes);
ms.WriteBuffer(buf[0], nBytes);
if ms.Size = fileSize then
begin
ms.Position := 0;
ms.SaveToFile('C:\Temp\Screen.bmp');
ms.Position := 0;
Synchronize(
procedure
begin
if FDesktopForm <> nil then
FDesktopForm.imgScreen.Picture.Bitmap.LoadFromStream(ms);
end
);
end;
end;
end;
finally
ms.Free;
end;
finally
Synchronize(
procedure
begin
if FDesktopForm <> nil then
FDesktopForm.Close;
end
);
end;
finally
SocketStrm.Free;
end;
end;
end.
procedure TMainForm.ServerSocketGetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket; var SocketThread: TServerClientThread);
begin
SocketThread := TThreadController.Create(false, ClientSocket);
end;
Client:
unit UntThreadMain;
interface
uses
System.Classes,
System.Win.ScktComp;
type
TThreadMain = class(TThread)
private
FClientSocket: TClientSocket;
FSocketStrm: TWinSocketStream;
procedure SendInfo;
procedure SendScreen;
procedure OnConnect(Sender: TObject; Socket: TCustomWinSocket);
procedure OnDisconnect(Sender: TObject; Socket: TCustomWinSocket);
procedure OnError(Sender: TObject; Socket: TCustomWinSocket; ErrorEvent: TErrorEvent; var ErrorCode: Integer);
protected
procedure Execute; override;
public
constructor Create(AHostname: string; APort: integer); reintroduce;
destructor Destroy; override;
end;
implementation
uses
System.SysUtils,
WinApi.Windows,
Vcl.Graphics,
UntClientMainForm,
UntSocketCommon;
{ TThreadMain }
constructor TThreadMain.Create(AHostname: string; APort: integer);
begin
inherited Create(false);
FreeOnTerminate := false;
FClientSocket := TClientSocket.Create(nil);
FClientSocket.ClientType := ctBlocking;
FClientSocket.Host := AHostname;
FClientSocket.Port := APort;
FClientSocket.OnConnect := OnConnect;
FClientSocket.OnDisconnect := OnDisconnect;
FClientSocket.OnError := OnError;
end;
destructor TThreadMain.Destroy;
begin
FClientSocket.Free;
inherited;
end;
procedure TThreadMain.Execute;
var
SocketStrm: TWinSocketStream;
cmd: String;
begin
FClientSocket.Open;
try
FSocketStrm := TWinSocketStream.Create(FClientSocket.Socket, 5000);
try
while FClientSocket.Socket.Connected and (not Terminated) do
begin
if SocketStrm.WaitForData(1000) then
begin
cmd := ReadLineFromSocket(SocketStrm);
if cmd = '<|INFO|>' then
begin
SendInfo
end
else if cmd = '<|GetScreen|>' then
begin
SendScreen;
end
end;
end;
finally
FSocketStrm.Free;
end;
finally
FClientSocket.Close;
end;
end;
procedure TThreadMain.OnConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Synchronize(
procedure
begin
ClientMainForm.stBar.Panels[1].Text := 'Conectado';
ClientMainForm.btnConectar.Caption := 'Desconectar';
end
);
end;
procedure TThreadMain.OnDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Synchronize(
procedure
begin
ClientMainForm.stBar.Panels[1].Text := 'Desconectado';
ClientMainForm.btnConectar.Caption := 'Conectar';
end
);
end;
procedure TThreadMain.OnError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
begin
ErrorCode := 0;
Socket.Close;
end;
procedure TThreadMain.SendInfo;
var
cmd: string;
begin
cmd := '<|INFO|>;NomePC=Tiago-PC;SO=Windows Seven Professiona 64-bit;CPU=Intel Core i7 3ª Geração';
WriteLineToSocket(FSocketStrm, cmd);
end;
procedure TThreadMain.SendScreen;
var
DC: HDC;
bmp: TBitmap;
ms: TMemoryStream;
begin
ms := TMemoryStream.Create;
try
bmp := TBitmap.Create;
try
DC := GetDC(0);
try
//bmp.PixelFormat := pf8bit;
bmp.Width := GetDeviceCaps(DC, HORZRES);
bmp.Height := GetDeviceCaps(DC, VERTRES);
//bmp.Width := Screen.Width;
//bmp.Height := Screen.Height;
BitBlt(bmp.Canvas.Handle, 0, 0, bmp.Width, bmp.Height, DC, 0, 0, SRCCOPY);
finally
ReleaseDC(0, DC);
end;
bmp.SaveToStream(ms);
finally
bmp.Free;
end;
ms.Position := 0;
WriteStreamToSocket(FSocketStrm, ms);
finally
ms.Free;
end;
end;
end.
procedure TClientMainForm.btnConectarClick(Sender: TObject);
begin
if FThreadMain = nil then
begin
FThreadMain := TThreadMain.Create('localhost', 6550);
end else
begin
FThreadMain.Terminate;
FThreadMain.WaitFor;
FThreadMain.Free;
FThreadMain := nil;
end;
end;