Is it possible to overlap the form title bar with an other control (TPanel) ?
Something like this:
As Jerry comments, maybe you could do with a StayOnTop form on which you put your panel. Assuming you design that panel as a (possibly left aligned) control on your mainform, the beginning of such a solution could look like this:
uses
Winapi.Windows, Winapi.Messages, System.Classes, Vcl.Controls, Vcl.Forms,
Vcl.ExtCtrls;
type
TMainForm = class(TForm)
Panel1: TPanel;
private
FStickIt: TForm;
protected
procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
procedure WMWindowPosChanged(var Message: TWMWindowPosChanged);
message WM_WINDOWPOSCHANGED;
public
constructor Create(AOwner: TComponent); override;
end;
implementation
{$R *.dfm}
constructor TMainForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FStickIt := TForm.CreateNew(Self);
FStickIt.AutoSize := True;
FStickIt.BorderStyle := bsNone;
FStickIt.FormStyle := fsStayOnTop;
FStickIt.Show;
Panel1.Align := alCustom;
Panel1.Parent := FStickIt;
end;
procedure TMainForm.WMSysCommand(var Message: TWMSysCommand);
begin
inherited;
case Message.CmdType and $FFF0 of
SC_MINIMIZE: FStickIt.Hide;
SC_RESTORE: FStickIt.Show;
end;
end;
procedure TMainForm.WMWindowPosChanged(var Message: TWMWindowPosChanged);
var
EdgeSize: Integer;
TitleBarInfoEx: TTitleBarInfoEx;
begin
inherited;
if Assigned(FStickIt) then
begin
EdgeSize := (Width - ClientWidth) div 2;
FStickIt.Left := Left + EdgeSize - BorderWidth;
FStickIt.Top := Top + GetSystemMetrics(SM_CYBORDER);
Panel1.Height := Height - EdgeSize - GetSystemMetrics(SM_CYBORDER) +
BorderWidth;
TitleBarInfoEx.cbSize := SizeOf(TitleBarInfoEx);
SendMessage(Handle, WM_GETTITLEBARINFOEX, 0, LPARAM(#TitleBarInfoEx));
Constraints.MinWidth := Panel1.Width + TitleBarInfoEx.rgrect[5].Right -
TitleBarInfoEx.rgrect[2].Left + 2 * EdgeSize - 2 * BorderWidth;
end;
end;
Related
In a 32-bit VCL Application in Windows 10 in Delphi 11 Alexandria, I am trying to write a small app that finds the list of ANCESTORS from a class name that the user inputs in an Edit box:
procedure TForm1.DoShowAncestors(const aClassName: string);
var
ClassRef: TClass;
begin
lstAncestors.Clear;
// Does not work:
//ClassRef := TClass.Create;
//ClassRef.ClassName := aClassName;
// [dcc32 Error] E2076 This form of method call only allowed for class methods or constructor:
ClassRef := TClass(aClassName).ClassType;
while ClassRef <> nil do
begin
lstAncestors.Items.Add(ClassRef.ClassName);
ClassRef := ClassRef.ClassParent;
end;
end;
procedure TForm1.edtClassNameKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if Key = VK_RETURN then
begin
DoShowAncestors(Trim(edtClassName.Text));
end;
end;
However, the problem is to transform the input string into a TClass object. See the above error comments.
Since Delphi is a compiled language, obtaining a class (or object) by name is not a natural operation, but requires some kind of framework.
Fortunately, modern RTTI (uses RTTI) can easily handle this for you:
procedure ShowAncestors(const AClass: string);
begin
var Ctx := TRttiContext.Create;
try
var LType := Ctx.FindType(AClass);
if LType is TRttiInstanceType then
begin
var R := TRttiInstanceType(LType).MetaclassType;
while Assigned(R) do
begin
ShowMessage(R.ClassName);
R := R.ClassParent;
end;
end;
finally
Ctx.Free; // actually, just to make the code "look" right!
end;
end;
Try it with
ShowAncestors('Vcl.Forms.TForm')
for instance.
(Of course, this only works for classes actually included in the final EXE.)
Now there is no more need to enter a fully qualified class name, and now there is a visual feedback validation of the class name in the edit:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Classes, Vcl.StdCtrls,
Vcl.ExtCtrls;
type
TForm1 = class(TForm)
edtClassName: TEdit;
lstAncestors: TListBox;
pnlEdit: TPanel;
procedure edtClassNameChange(Sender: TObject);
procedure edtClassNameKeyDown(Sender: TObject; var Key: Word; Shift:
TShiftState);
procedure edtClassNameKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure FormActivate(Sender: TObject);
private
FDontDoIt: Boolean;
function CheckEmptyEdit: Boolean;
procedure DoShowAncestors(const aClassName: string);
function GetMatchingTypeName: string;
procedure SetEditBorder;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
System.StrUtils,
System.RTTI;
function FindMyClass(const aName: string): TClass;
var
ctx: TRttiContext;
ThisType: TRttiType;
ThisList: TArray<TRttiType>;
FPos: Integer;
begin
Result := nil;
ctx := TRttiContext.Create;
try
ThisList := ctx.GetTypes;
for ThisType in ThisList do
begin
if ThisType.IsInstance and (EndsText(aName, ThisType.Name)) then
begin
Result := ThisType.AsInstance.MetaClassType;
BREAK;
end;
end;
finally
ctx.Free;
end;
end;
procedure TForm1.edtClassNameChange(Sender: TObject);
var
ctx: TRttiContext;
ThisType: TRttiType;
ThisList: TArray<TRttiType>;
InputStr: string;
FPos: Integer;
begin
if CheckEmptyEdit then
EXIT;
if FDontDoIt then
begin
FDontDoIt := False;
EXIT;
end;
FPos := edtClassName.SelStart;
var ThisMatchingTypeName := GetMatchingTypeName;
FDontDoIt := True;
try
if ThisMatchingTypeName <> '' then
edtClassName.Text := ThisMatchingTypeName;
finally
FDontDoIt := False;
end;
SetEditBorder;
if pnlEdit.Color <> clRed then
begin
edtClassName.SelStart := FPos;
edtClassName.SelLength := Length(ThisMatchingTypeName) - FPos;
end;
end;
procedure TForm1.SetEditBorder;
begin
if FindMyClass(Trim(edtClassName.Text)) = nil then
begin
pnlEdit.Color := clRed;
lstAncestors.Clear;
end
else
pnlEdit.Color := clGreen;
end;
function TForm1.GetMatchingTypeName: string;
var
ctx: TRttiContext;
ThisType: TRttiType;
ThisList: TArray<TRttiType>;
InputStr: string;
begin
Result := '';
InputStr := Trim(edtClassName.Text);
if InputStr = '' then EXIT;
ctx := TRttiContext.Create;
try
ThisList := ctx.GetTypes;
for ThisType in ThisList do
begin
if ThisType.IsInstance and (StartsText(InputStr, ThisType.Name)) then
begin
Result := ThisType.Name;
BREAK;
end;
end;
finally
ctx.Free;
end;
end;
procedure TForm1.DoShowAncestors(const aClassName: string);
var
ClassRef: TClass;
begin
lstAncestors.Items.BeginUpdate;
try
lstAncestors.Clear;
ClassRef := FindMyClass(aClassName);
while ClassRef <> nil do
begin
lstAncestors.Items.Add(ClassRef.ClassName);
ClassRef := ClassRef.ClassParent;
end;
finally
lstAncestors.Items.EndUpdate;
end;
end;
procedure TForm1.edtClassNameKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
case Key of
VK_BACK: FDontDoIt := True;
VK_DELETE: FDontDoIt := True;
end;
end;
procedure TForm1.edtClassNameKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
case Key of
VK_RETURN: DoShowAncestors(Trim(edtClassName.Text));
VK_BACK:
begin
FDontDoIt := False;
SetEditBorder;
CheckEmptyEdit;
end;
VK_DELETE:
begin
FDontDoIt := False;
SetEditBorder;
CheckEmptyEdit;
end;
end;
end;
function TForm1.CheckEmptyEdit: Boolean;
begin
Result := False;
if Trim(edtClassName.Text) = '' then
begin
pnlEdit.Color := clGray;
lstAncestors.Clear;
Result := True;
end;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
edtClassName.SetFocus;
end;
end.
And here is the DFM:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Show Class Ancestors'
ClientHeight = 300
ClientWidth = 434
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -15
Font.Name = 'Segoe UI'
Font.Style = []
Position = poScreenCenter
ShowHint = True
OnActivate = FormActivate
PixelsPerInch = 120
TextHeight = 20
object lstAncestors: TListBox
AlignWithMargins = True
Left = 16
Top = 55
Width = 402
Height = 229
Margins.Left = 16
Margins.Top = 16
Margins.Right = 16
Margins.Bottom = 16
Align = alClient
ItemHeight = 20
TabOrder = 0
ExplicitTop = 60
ExplicitHeight = 224
end
object pnlEdit: TPanel
AlignWithMargins = True
Left = 16
Top = 16
Width = 402
Height = 23
Margins.Left = 16
Margins.Top = 16
Margins.Right = 16
Margins.Bottom = 0
Align = alTop
BevelOuter = bvNone
Caption = 'pnlEdit'
Color = clGray
ParentBackground = False
TabOrder = 1
object edtClassName: TEdit
AlignWithMargins = True
Left = 1
Top = 1
Width = 400
Height = 21
Hint = 'Enter a known Class Name and then press the Enter/Return key.'
Margins.Left = 1
Margins.Top = 1
Margins.Right = 1
Margins.Bottom = 1
Align = alClient
BorderStyle = bsNone
TabOrder = 0
OnChange = edtClassNameChange
OnKeyDown = edtClassNameKeyDown
OnKeyUp = edtClassNameKeyUp
ExplicitLeft = 0
ExplicitTop = 0
ExplicitWidth = 402
ExplicitHeight = 28
end
end
end
how are you?
I come here ask for a solution, how prevent TIdTcpServer stuck connections?
Version of indy 10.6.2.5341 and Rad Studio 10.1 Berlin
On both images show the number of connections on TIdTcpServer, these numbers are retrieved from this function:
var
NumClients: Integer;
begin
with Form1.IdTCPServer1.Contexts.LockList do
try
NumClients := Count;
finally
Form1.IdTCPServer1.Contexts.UnlockList;
end;
Result := NumClients;
What happen is, in almost cases this numbers only increase and not decrease. so i believe connections are being stucked on TIdTcpServer.
I use a IdSchedulerOfThreadDefault1 on Scheduler, i don't know if that change something or no but i added.
For manage connections i use ContextClass:
IdTCPServer1.ContextClass := TClientContext;
Who definition is:
type
TCommand = (
cmdConnect,
cmdDisconnect,
cmdHWID,
cmdScreenShotData,
cmdMensagem);
type
TClient = record
HWID : String[40];
Tempo : TDateTime;
Msg : String[100];
end;
const
szClient = SizeOf(TClient);
type
TProtocol = record
Command: TCommand;
Sender: TClient;
DataSize: Integer;
end;
const
szProtocol = SizeOf(TProtocol);
type
TClientContext = class(TIdServerContext)
private
FCriticalSection : TCriticalSection;
FClient : TClient;
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
public
procedure Lock;
procedure Unlock;
public
property Client: TClient read FClient write FClient;
end;
Others functions who are used:
procedure InitProtocol(var AProtocol: TProtocol);
begin
FillChar(AProtocol, szProtocol, 0);
end;
function ProtocolToBytes(const AProtocol: TProtocol): TBytes;
begin
SetLength(Result, szProtocol);
Move(AProtocol, Result[0], szProtocol);
end;
constructor TClientContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited Create(AConnection, AYarn, AList);
FCriticalSection := TCriticalSection.Create;
end;
destructor TClientContext.Destroy;
begin
FreeAndNil(FCriticalSection);
inherited;
end;
procedure TClientContext.Lock;
begin
FCriticalSection.Enter;
end;
procedure TClientContext.Unlock;
begin
FCriticalSection.Leave;
end;
function BytesToProtocol(const ABytes: TBytes): TProtocol;
begin
Move(ABytes[0], Result, szProtocol);
end;
procedure ClearBuffer(var ABuffer: TBytes);
begin
SetLength(ABuffer, 0);
end;
procedure ClearBufferId(var ABuffer: TIdBytes);
begin
SetLength(ABuffer, 0);
end;
All events (connect/disconnect) i manage on IdTCPServer1Execute
like this example above:
type
PTBytes = ^TBytes;
PTIdBytes = ^TIdBytes;
var
LBuffer : TIdBytes;
LProtocol : TProtocol;
FTempBuffer : TIdBytes;
Enviar : TBytes;
Protocolo : TProtocol;
Conexao : TClientContext;
//
Queue: TStringList;
List: TStringList;
x : Integer;
//
procedure AddToMemo(const AStr: string);
begin
TThread.Synchronize(nil,
procedure
begin
Memo1.Lines.Add(AStr);
Form1.StatusBar1.Panels[0].Text := Format('Connections [%d]', [RetornaOn]);
end
);
end;
begin
Conexao := TClientContext(AContext);
// QUEUE
List := nil;
try
Queue := Conexao.Queue.Lock;
try
if Queue.Count > 0 then
begin
List := TStringList.Create;
List.Assign(Queue);
Queue.Clear;
end;
finally
Conexao.Queue.Unlock;
end;
if List <> nil then
begin
for x := 0 to List.Count-1 do
begin
InitProtocol(Protocolo);
Protocolo.Command := cmdMensagem;
Protocolo.Sender.Msg := Edit2.Text;
Enviar := ProtocolToBytes(Protocolo);
Conexao.Connection.IOHandler.Write(PTIdBytes(#Enviar)^);
ClearBuffer(Enviar);
end;
// Delete Queue
for x := 0 to List.Count-1 do
begin
List.Delete(x);
end;
end;
finally
List.Free;
end;
// QUEUE
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
//AddToMemo(Format('[%s] Running 1 ...', [TimeToStr(Now)]));
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
{AddToMemo(Format('[%s] Running 2 ...', [TimeToStr(Now)]));
if GetTickDiff(Conexao.Client.Tick, Ticks) >= 10000 then
begin
AddToMemo(Format('[%s] Running 3 [%d] ...', [TimeToStr(Now), Conexao.Client.Tick]));
AContext.Connection.Disconnect;
Exit;
end;}
Exit;
end;
end;
AContext.Connection.IOHandler.ReadBytes(LBuffer, szProtocol, False);
LProtocol := BytesToProtocol(PTBytes(#LBuffer)^);
case LProtocol.Command of
cmdConnect: begin
Conexao.Client := LProtocol.Sender;
Conexao.FClient.Tick := Ticks;
AddToMemo(Format('[%s] : [%s][%s]', ['Connect', AContext.Connection.Socket.Binding.PeerIP, Protocolo.Sender.HWID]));
end;
cmdMensagem: begin
AddToMemo(Format('[%s] : [%s][%s][%s]', ['Msg', AContext.Connection.Socket.Binding.PeerIP, Conexao.Client.HWID, LProtocol.Sender.Msg]));
end;
cmdDisconnect: begin
AddToMemo(Format('[%s] : [%s][%s]', ['Disconnect', AContext.Connection.Socket.Binding.PeerIP, Conexao.Client.HWID]));
end;
end;
In next code i show how client side connect to TIdTcpServer:
type
PTIdBytes = ^TIdBytes;
var
LBuffer : TBytes;
LProtocol : TProtocol;
begin
ClientThread := TClientThread.Create(False);
InitProtocol(LProtocol);
LProtocol.Command := cmdConnect;
LProtocol.Sender.HWID := Edit1.Text;
LProtocol.Sender.Tempo := Now;
LBuffer := ProtocolToBytes(LProtocol);
IdTCPClient1.IOHandler.Write(PTIdBytes(#LBuffer)^);
ClearBuffer(LBuffer);
AddToMemo('IdTCPClient1 connected to server');
ClientThread on client:
procedure TClientThread.Execute;
type
PTBytes = ^TBytes;
PTIdBytes = ^TIdBytes;
var
LBuffer : TIdBytes;
LDataSize : Integer;
LProtocol : TProtocol;
procedure AddToMemo(const AStr: string);
begin
TThread.Synchronize(nil,
procedure
begin
Form1.Memo1.Lines.Add('Received From Server: ' + AStr);
end
);
end;
begin
inherited;
while NOT Terminated and Form1.IdTCPClient1.Connected do begin
//LDataSize := Form1.IdTCPClient1.IOHandler.InputBuffer.Size;
//if LDataSize >= szProtocol then begin
try
Form1.IdTCPClient1.IOHandler.ReadBytes(LBuffer, szProtocol);
LProtocol := BytesToProtocol(PTBytes(#LBuffer)^);
case LProtocol.Command of
cmdHWID:
begin
HWID := LProtocol.Sender.HWID;
AddToMemo('HWID > ' + LProtocol.Sender.HWID);
end;
cmdDisconnect:
begin
AddToMemo('DC > ' + LProtocol.Sender.HWID);
end;
cmdMensagem:
begin
AddToMemo('MSG > ' + LProtocol.Sender.Msg);
end;
end;
finally
ClearBufferId(LBuffer);
end;
//end;
Sleep(50);
end;
end;
Anybody know why these connections are being stucked on TIdTcpServer?
Maybe if i loop all conenctions and try send a single text will disconnect they if don't are really connected to IdTcpServer no ?
Thanks.
I have a TAction.OnExecute event handler triggered from my main form,
FormPrincipal, which opens other Forms.
procedure TFormPrincipal.AbreFormBancoExecute(Sender: TObject);
begin
Formbanco := Tformbanco.Create(self);
Formbanco.Parent := PanelCorpo;
Formbanco.Align := alclient;
Formbanco.BorderIcons := [];
Formbanco.Show;
Formbanco.BorderStyle := bsNone;
Formbanco.SetFocus;
end;
Once I'll have several forms, how to know which one is opened and how to close it, before triggering OnExecute to open another Form?
=========== Finally it is Working as I expected =======
The main form is form1 from which I call form2 and form3. In form1 I have a panel1 which is parent of form2 and form3. See form1 code :
...
var
Form1: TForm1;
implementation
{$R *.dfm}
uses unit2, unit3;
procedure Tform1.CloseActiveForm (Formname : string);
// Free memory allocated to the current form , set it to nil
// I'll have to find a better way to perform FreeanNil without
// use many IFs command
begin
if Formname = 'form2' then FreeAndnil(Form2) else
if Formname = 'form3' then FreeandNil(Form3);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
CloseActiveForm(Edit1.Text); //Edit1 has the current active form name
if form2 = nil then
begin
Application.CreateForm(Tform2,Form2);
Form2.Parent := Panel1;
Form2.Align := alclient;
Form2.Show;
Form2.BorderStyle := bsnone;
Form2.SetFocus;
Form2.OnActivate(Sender); //Method Show blocks Activate event
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
CloseActiveForm(Edit1.Text); //Edit1 has the current active form name
if form3 = nil then
begin
Application.CreateForm(Tform3,Form3);
Form3.Parent := Panel1;
Form3.Align := alclient;
Form3.Show;
Form3.BorderStyle := bsnone;
Form3.SetFocus;
Form3.OnActivate(Sender); //Method Show blocks Activate event
end;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
Edit1.Text := Screen.ActiveForm.Name;
end;
end.
2) Code in form2 and form3 (consider form3 is identical)
...
var
Form2: TForm2;
implementation
{$R *.dfm}
uses unit1;
procedure TForm2.Button1Click(Sender: TObject);
begin
Edit2.Text := Screen.ActiveForm.Name;
end;
procedure TForm2.FormActivate(Sender: TObject);
begin
setfocus;
Edit1.Text := Form2.Name;
Form1.Edit1.Text := Form2.Name; //set form name
// the property Screen.ActiveForm.Name if used here, will always presents
// form1 name (main form) because this form2 is set to a parent panel
// in form1
end;
end.
Destroy the form if it exist and create a new instance of it.
procedure TFormPrincipal.AbreFormBancoExecute(Sender: TObject);
procedure CreateFormbanco;
begin
Formbanco := TFormbanco.Create(self);
Formbanco.Parent := PanelCorpo;
Formbanco.Align := alclient;
Formbanco.BorderIcons := [];
Formbanco.BorderStyle := bsNone;
Formbanco.Show;
Formbanco.SetFocus;
Formbanco.OnDestroy := FormDestroyEvent;
end;
begin
if not Assigned(Formbanco) then
begin
CreateFormbanco;
end
else
begin
Formbanco.Destroy;
CreateFormbanco;
end;
procedure TFormPrincipal.FormDestroyEvent(Sender: TObject);
begin
Formbanco := nil;
end;
This code will check if Formbanco existed, if so it will destroy it and create a new instance of it otherwise it will create a new one.
Edit: create different forms and use the code above, just change Formbanco and TFormbanco to their respected new form name.
I'm with difficulties for send text from a Client.Socket. The Form that sends the text, is displayed always above of Form that stays always on top, when FormOnTop not exists (not is showing), works fine, already when FormOnTop exists and Form that will sends the text is displayed above of FormOntop, the send fail, and text (message) not even exit of Client.exe of my software.
There are some solution for this?
For better understand, I will leave the code that I using:
Form that contains Client Socket component
unit Unit1;
interface
uses
FormSender;
type
......
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.CS1Read(Sender: TObject; Socket: TCustomWinSocket);
var
StrCommand: String;
begin
StrCommand := Socket.ReceiveText;
if Pos('<|Command_From_Server|>', StrCommand) > 0 then
begin
FormSender.PopupMode:= pmExplicit;
FormSender.PopupParent:= FormOnTop;
FormSender.Show;
end;
end;
end.
Form that sends text (FormSender) and appear above of Form that stays always On Top:
unit FormSender;
interface
uses
Unit1;
type
......
end;
var
FormSender: TFormSender;
implementation
{$R *.dfm}
procedure TFormSender.Button1Click(Sender: TObject);
begin
Form1.CS1.Socket.SendText('<|Hello_Server!|>' + Edit1.Text + '<<|);
end;
end.
Form that stays always on top:
FormStyle property is: fsStayOnTop.
unit FormOnTop;
interface
uses
.......
type
......
end;
var
FormOnTop: TFormOnTop;
implementation
{$R *.dfm}
procedure TFormOnTop.FormCreate(Sender: TObject);
begin
{ Position form }
Top := 0 ;
Left := 0 ;
{ Go full screen }
BorderStyle := bsNone ;
WindowState := wsmaximized;
ClientWidth := Screen.Width ;
ClientHeight := Screen.Height;
Refresh;
SetForegroundWindow(Handle) ;
SetActiveWindow(Application.Handle);
end;
procedure TFormOnTop.CreateParams(var Params: TCreateParams);
begin
inherited;
if (FormStyle = fsStayOnTop) then begin
Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;
Params.WndParent := GetDesktopWindow;
end;
end;
procedure TFormOnTop.FormShow(Sender: TObject);
begin
SetWindowPos(FormOnTop.handle, HWND_TOPMOST, FormOnTop.Left, FormOnTop.Top, FormOnTop.Width, FormOnTop.Height, 0);
end;
end.
On the server side, text is entered into a memobox. This text is then sent to the Server side using this code:
var
ftmpstr :String;
buf :array[0..255] of char;
msize, nyites :dword;
i :Integer;
..
Command := Socket.ReceiveText;
if split(Command,'|', 0) = 'IBATCH' then
begin
ftmpstr := IBat.Memo1.Text;
nyites := 1;
msize := length(ftmpstr);
Server.Socket.Connections[ListView1.Selected.Index].SendText(IntToStr(msize));
while msize>255 do
begin
for i := 0 to 255 do
buf[i] := ftmpstr[nyites+i];
Server.Socket.Connections[Form1.ListView1.Selected.Index].SendBuf(buf,256);
dec(msize,256);
inc(nyites,256);
end;
if msize>0 then
begin
for i := 0 to msize-1 do
buf[i] := ftmpstr[nyites+i];
Server.Socket.Connections[Form1.ListView1.Selected.Index].SendBuf(buf,msize);
end;
end;
Code on the Server side:
Socket.SendText('IBATCH');
ftmpstr:='';
mbytesleft := strtoint(Socket.ReceiveText);
SetLength(ftmpstr,mbytesleft);
nyites:=1;
while mbytesleft>255 do
begin
Socket.ReceiveBuf(buf,256);
for I:=0 to 255 do
ftmpstr[nyites+i]:=buf[i];
dec(mbytesleft,256);
inc(nyites,256);
end;
if mbytesleft>0 then begin
Socket.ReceiveBuf(buf,mbytesleft);
for I:=0 to mbytesleft-1 do
ftmpstr[nyites+i]:=buf[i];
end;
nfile:=TempDir+IntToStr(GetTickCount)+'.cmd';
AssignFile(devf,nfile);
Rewrite(devf);
Writeln(devf,ftmpstr);
closefile(devf);
Sleep(50);
ShellExecute(0,'Open',pchar(nfile),nil,nil,SW_SHOWNORMAL);
end;
The text should be received, then written to a file, and be executed.
I did however find the code online and modify it to work with TServerSocket and TClientSocket components. I created a successful connection between the client and server, but the above code just doesn't want to work. Maybe someone with more expertise could help me get this working.
Any help would be greatly appreciated.
Your code has no structured protocol to it. TCP is a stream of raw bytes, and you are sending everything as strings (and not doing a very good job of it - no error handling, no partial send/receive handling, etc). You need to delimit your fields/messages from one another. Then the receiver can look for those delimiters. You would have to read everything from the socket into an intermediate buffer, checking the buffer for a message terminator, and then extract only completed messages and process them as needed.
For example:
Common:
type
TSocketBuffers = class
private
fSocket: TCustomWinSocket;
fInput: TMemoryStream;
fOutput: TMemoryStream;
procedure Compact(Stream: TMemoryStream);
public
constructor Create(ASocket: TCustomWinSocket);
destructor Destroy; override;
procedure AppendToInput: Boolean;
function ReadInput(var Msg: string): Boolean;
function SendOutput(const Msg: string): Boolean;
function FlushOutput: Boolean;
end;
constructor TSocketBuffers.Create(ASocket: TCustomWinSocket);
begin
inherited Create;
fSocket := ASocket;
fInput := TMemoryStream.Create;
fOutput := TMemoryStream.Create;
end;
destructor TSocketBuffers.Destroy;
begin
fInput.Free;
fOutput.Free;
inherited;
end;
procedure TSocketBuffers.Compact(Stream: TMemoryStream);
begin
if Stream.Position < Stream.Size then
begin
Move(Pointer(Longint(Stream.Memory) + Stream.Position)^, Stream.Memory^, Stream.Size - Stream.Position);
Stream.Size := Stream.Position;
Stream.Position := 0;
end else begin
Stream.Clear;
end;
end;
function TSocketBuffers.AppendToInput: Boolean;
var
buf: array[0..255] of Byte;
nBuf: Integer;
begin
nBuf := fSocket.ReceiveBuf(buf[0], sizeof(buf));
if nBuf > 0 then
begin
fInput.Seek(0, soEnd);
fInput.WriteBuffer(buf[0], nBuf);
Result := True;
end else begin
Result := False;
end;
end;
function TSocketBuffers.ReadInput(var Msg: string): Boolean;
var
b: Byte;
tmp: string;
needed: Integer;
begin
Result := False;
Msg := '';
fInput.Position := 0;
while fInput.Position < fInput.Size do
begin
fInput.ReadBuffer(b, 1);
if b = Ord('|') then
begin
SetString(tmp, PAnsiChar(fInput.Memory), fInput.Position-1);
needed := StrToInt(tmp);
if needed > 0 then
begin
if (fInput.Size - fInput.Position) < Int64(needed) then
Exit;
SetLength(Msg, needed);
fInput.ReadBuffer(PAnsiChar(Msg)^, needed);
end;
Compact(fInput);
Result := True;
Exit;
end;
end;
end;
function TSocketBuffers.SendOutput(const Msg: string): Boolean;
var
tmp: AnsiString;
nSent: Integer;
begin
Result := True;
tmp := IntToStr(Length(Msg)) + '|' + Msg;
if fOutput.Size = 0 then
begin
repeat
nSent := fSocket.SendBuf(PAnsiChar(tmp)^, Length(tmp));
if nSent < 0 then
begin
if WSAGetLastError() <> WSAEWOULDBLOCK then
begin
Result := True;
Exit;
end;
Break;
end;
Delete(tmp, 1, nSent);
until tmp = '';
end;
if tmp <> '' then
begin
fOutput.Seek(0, soEnd);
fOutput.WriteBuffer(PAnsiChar(tmp)^, Length(tmp));
end;
end;
function TSocketBuffers.FlushOutput: Boolean;
var
buf: array[0..255] of Byte;
nBuf, nSent: Integer;
begin
Result := True;
fOutput.Position := 0;
while fOutput.Position < fOutput.Size do
begin
nBuf := fOutput.Read(buf[0], sizeof(buf));
nSent := fSocket.SendBuf(buf[0], nBuf);
if nSent < 0 then
begin
if WSAGetLastError() <> WSAEWOULDBLOCK then
begin
fOutput.Seek(-nBuf, soCurrent);
Result := False;
end;
Break;
end;
end;
if fOutput.Position > 0 then
Compact(fOutput);
end;
Server:
procedure TForm1.ServerSocketConnect(Sender: TObject; Socket: TCustomWinSocket);
begin
Socket.Data := TSocketBuffers.Create(Socket);
end;
procedure TForm1.ServerSocketDisconnect(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketBuffers(Socket.Data).Free;
end;
procedure TForm1.ServerSocketRead(Sender: TObject; Socket: TCustomWinSocket);
var
bufs: TSocketBuffers;
Command: string;
begin
bufs := TSocketBuffers(Socket.Data);
if not bufs.AppendToInput then Exit;
while bufs.ReadInput(Command) do
begin
if split(Command, '|', 0) = 'IBATCH' then
bufs.SendOutput(IBat.Memo1.Text);
end;
end;
procedure TForm1.ServerSocketWrite(Sender: TObject; Socket: TCustomWinSocket);
begin
TSocketBuffers(Socket.Data).FlushOutput;
end;
Client:
bufs := TSocketBuffers.Create(Client.Socket);
...
// this is assuming TClientSocekt is set to blocking mode
// otherwise you have to use the OnRead and OnWrite events...
if bufs.SendOutput('IBATCH') then
begin
while bufs.AppendToInput do
begin
if bufs.ReadInput(ftmpstr) then
begin
nfile := TempDir+IntToStr(GetTickCount) + '.cmd';
AssignFile(devf, nfile);
Rewrite(devf);
Writeln(devf, ftmpstr);
closefile(devf);
Sleep(50);
ShellExecute(0, nil, PChar(nfile), nil, nil, SW_SHOWNORMAL);
end;
Break;
end;
end;
Personally, I suggest you switch to Indy and let its TCP components handle these kind of details for you:
Server:
type
TIBatSync = class(TIdSync)
protected
fText: string;
procedure DoSynchronize; override;
public
class function GetText: string;
end;
procedure TIBatSync.DoSynchronize;
begin
fText := Form1.IBat.Memo1.Text;
end;
class function TIBatSync.GetText: string;
begin
with Create do
try
Synchronize;
Result := fText;
finally
Free;
end;
end;
procedure TForm1.IdTCPServerExecue(AContext: TIdContext);
var
Command, tmp: string;
begin
tmp := AContext.Connection.IOHandler.ReadLn('|');
Command := AContext.Connection.IOHandler.ReadString(StrToInt(tmp));
if split(Command, '|', 0) = 'IBATCH' then
begin
tmp := TIBatSync.GetText;
AContext.Connection.IOHandler.Write(Length(tmp) + '|' + tmp);
end;
end;
Client:
Client.IOHandler.Write('6|IBATCH');
ftmpstr := Client.IOHandler.ReadLn('|');
ftmpstr := Client.IOHandler.ReadString(StrToInt(ftmpstr));
nfile := TempDir+IntToStr(GetTickCount) + '.cmd';
AssignFile(devf, nfile);
Rewrite(devf);
Writeln(devf, ftmpstr);
closefile(devf);
Sleep(50);
ShellExecute(0, nil, PChar(nfile), nil, nil, SW_SHOWNORMAL);