delphi Activex and parented forms error - forms

i try to fix up my activex project and i had errors , i have 2 forms in my activex project first form hold tmemo and button to call second form as parented form every thing works fine till now but i cannot set any record from second form to first form control always get access violation so i decided to show result before set tmemo.text control in the first form and actually result is showing but but cannot be set into the first form here is my project code
unit main1;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, embed_TLB, StdVcl, Vcl.StdCtrls;
type
Tform1 = class(TForm, Iform1)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
procedure showEmo(L,T:Integer);
end;
var
Form1 : Tform1;
implementation
uses ComObj, ComServ, main2;
{$R *.DFM}
{ Tform1 }
procedure Tform1.Button1Click(Sender: TObject);
var
Rect: TRect;
begin
GetWindowRect(Self.button1.Handle, Rect);
showEmo(Rect.Left + 70,(Rect.Top - 290));
end;
procedure Tform1.FormCreate(Sender: TObject);
begin
Form2 := TForm2.Createparented(0);
end;
procedure TForm1.showEmo(L,T:Integer);
var
Rect: TRect;
begin
try
GetWindowRect(button1.Handle, Rect);
begin
Form2.FormStyle := fsStayOnTop;
end;
Form2.Left := L;//Rect.Left;
Form2.top := T;//Rect.Top - emo.Height;
finally
Form2.Visible := not (Form2.visible);
end;
end;
initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
Tform1,
Class_form1,
0,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
end.
Form 2
unit main2;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.OleCtrls, SHDocVw_EWB, EwbCore,
EmbeddedWB, MSHTML_EWB, Vcl.StdCtrls;
type
TForm2 = class(TForm)
ewbpage: TEmbeddedWB;
load: TMemo;
procedure FormCreate(Sender: TObject);
procedure ewbpageBeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses main1;
{$R *.dfm}
procedure TForm2.ewbpageBeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool);
var
MousePos: TPoint;
HtmlElement: IHTMLElement;
iHTMLDoc: IHtmlDocument2;
begin
if Pos('#sm',URL)>0 then
begin
if Supports(ewbpage.Document, IHtmlDocument2, iHTMLDoc) then
begin
if GetCursorPos(MousePos) then
begin
MousePos := ewbpage.ScreenToClient(MousePos);
HtmlElement := iHTMLDoc.ElementFromPoint(MousePos.X, MousePos.Y);
if Assigned(HtmlElement) then
showmessage(HtmlElement.getAttribute('id', 0));
form1.Memo1.Text := HtmlElement.getAttribute('id', 0);
Cancel := True;
Self.Close;
end;
end;
end;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
ewbpage.LoadFromStrings(load.Lines);
end;
end.
and the question is why i get this error
Access violation at address 07C734FC in module 'EMBEDA~1.OCX'. Read of
address 000003B4.
at this line
form1.Memo1.Text := HtmlElement.getAttribute('id', 0);
why i cannot set result from second form to first form ? what i did wrong here is the full project for better understand
http://www.mediafire.com/download/zn7hzoxze2390a3/embeddedactivex.zip

You will see this issue once you start to format your code properly
procedure TForm2.ewbpageBeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool);
var
MousePos: TPoint;
HtmlElement: IHTMLElement;
iHTMLDoc: IHtmlDocument2;
begin
if Pos('#sm',URL)>0 then
begin
if Supports(ewbpage.Document, IHtmlDocument2, iHTMLDoc) then
begin
if GetCursorPos(MousePos) then
begin
MousePos := ewbpage.ScreenToClient(MousePos);
HtmlElement := iHTMLDoc.ElementFromPoint(MousePos.X, MousePos.Y);
// if we have a valid HtmlElement ...
if Assigned(HtmlElement)
then // show a message
showmessage(HtmlElement.getAttribute('id', 0));
// now we do not care about if HtmlElement is valid or not
form1.Memo1.Text := HtmlElement.getAttribute('id', 0);
Cancel := True;
Self.Close;
end;
end;
end;
end;
To only solve your current access violation you simply put a begin end block around all the lines that will use HtmlElement.
HtmlElement := iHTMLDoc.ElementFromPoint( MousePos.X, MousePos.Y );
if Assigned( HtmlElement )
then
begin
showmessage( HtmlElement.getAttribute( 'id', 0 ) );
form1.Memo1.Text := HtmlElement.getAttribute( 'id', 0 );
end;
But there are some more issues in your code. You should not use the global variables form1 and form2. Instead pass the form instance to the created TForm2 instance or even better a callback method.

Related

In Delphi, how can I modify cells in a TStringGrid using a DLL procedure?

In Embarcadero Delphi v10.1 I have both a DLL library with a record, and a VCL application containing a TStringGrid and a TEdit. The idea is to take the shortstring entered into the TEdit; save it to the record in the DLL and then use the data stored in the record to fill in one of the cells in the TStringGrid.
My problem is that after saving the shortstring to the record I can't seem to find a way to access the TStringGrid while inside the DLL procedure. So far I have tried using both classes and pointers to access the TStringGrid in the DLL but neither has worked:
type
pstringgrid = ^TStringGrid;
//or
type
pstringgrid = ^stringgrid1;
//or
type
istringgrid = class(TStringGrid);
I have even tried to import the TStringGrid into the procedure which is supposed to enter the shortstring from the record into the TStringGrid:
procedure AddElement (var grid : stringgrid1); stdcall;
//or
type
pstringgrid = ^TStringGrid;
procedure AddElement (var grid : ^pstringgrid); stdcall;
So far nothing has worked and all I am getting is the "undecleared identifier" error message from the debugger; please help! How can I access and edit a TStringGrid while in a DLL procedure?
Edit:
Here is the relevant code, sorry for the foreign variable names.
The DLL:
library BibliotekaDLL;
uses
System.SysUtils,
System.Classes;
type
StringGrid1 = class(TStringGrid);
plist = ^game;
game = record
nazwa: shortstring;
wydawca: shortstring;
rokwyd: integer;
gatunek1: shortstring;
gatunek2: shortstring;
pointer: plist;
end;
var
BazaDanych : file of game;
first, current: plist;
[...]
procedure WyswietlListe; stdcall;
var
row : integer;
begin
AssignFile(BazaDanych, 'c:\Baza_Danych_Gier.dat');
if not FileExists('c:\Baza_Danych_Gier.dat') then
ShowMessage ('Baza Danych Nie Instnieje' +E.Message)
else
begin
Reset(BazaDanych);
Read(BazaDanych, first);
Close(BazaDanych);
current := first;
row := 1;
while current^.pointer <> nil do
begin
current := first;
StringGrid1.Cells[0,row] := current^.nazwa;
StringGrid1.Cells[1,row] := current^.wydawca;
StringGrid1.Cells[2,row] := current^.rokwyd;
StringGrid1.Cells[3,row] := current^.gatunek1;
StringGrid1.Cells[4,row] := current^.gatunek2;
current := current^.pointer;
row = row +1;
StringGrid1.RowCount := row;
end;
if current^.pointer = nil do
begin
StringGrid1.Cells[0,row] := current^.nazwa;
StringGrid1.Cells[1,row] := current^.wydawca;
StringGrid1.Cells[2,row] := current^.rokwyd;
StringGrid1.Cells[3,row] := current^.gatunek1;
StringGrid1.Cells[4,row] := current^.gatunek2;
end;
end;
end;
[...]
And the VCL application code:
[...]
type
TForm1 = class(TForm)
Button2: TButton;
StringGrid1: TStringGrid;
procedure Button2Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
[...]
procedure TForm1.Button2Click(Sender: TObject);
var
Handle : THandle;
WyswietlListe : procedure;
begin
Handle := LoadLibrary('BibliotekaDLL.dll');
try
#WyswietlListe:= GetProcAddress(Handle, 'WyswietlListe');
if #WyswietlListe = nil then raise Exception.Create('Nie Można Znaleźć Procedury w Bibliotece!');
WyswietlListe;
finally
FreeLibrary(Handle);
end;
end;
[...]
My problem is that after saving the shortstring to the record I can't seem to find a way to access the TStringGrid while inside the DLL procedure.
Don't do that. It is bad design.
For one thing, it is not safe to access objects across the DLL boundary unless both app and DLL are compiled with Runtime Packages enabled so they share a single instance of the RTL and memory manager.
It is best if the DLL has no knowledge of your UI at all. If the DLL needs to communicate info to the app, the DLL should define a callback event that the app can assign a handler for, and then the DLL can call that event when needed. Let the app decide how to manage its own UI.
Also, your game record has a pointer member, but pointers cannot be persisted in files. You need to remove that member.
Try something more like this:
library BibliotekaDLL;
uses
System.SysUtils,
System.Classes,
Vcl.Dialogs;
type
game = packed record
nazwa: shortstring;
wydawca: shortstring;
rokwyd: integer;
gatunek1: shortstring;
gatunek2: shortstring;
end;
gameCallback = procedure(var g: game; userData: Pointer); stdcall;
procedure WyswietlListe(callback: gameCallback; userData: Pointer); stdcall;
var
BazaDanych : File of game;
current: game;
begin
AssignFile(BazaDanych, 'c:\Baza_Danych_Gier.dat');
Reset(BazaDanych);
if IOResult <> 0 then
ShowMessage ('Baza Danych Nie Instnieje')
else
try
repeat
Read(BazaDanych, current);
if IOResult <> 0 then Break;
if Assigned(callback) then callback(current, userData);
until False;
finally
Close(BazaDanych);
end;
end;
exports
WyswietlListe;
end.
interface
type
TForm1 = class(TForm)
Button2: TButton;
StringGrid1: TStringGrid;
procedure Button2Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
type
game = packed record
nazwa: shortstring;
wydawca: shortstring;
rokwyd: integer;
gatunek1: shortstring;
gatunek2: shortstring;
end;
gameCallback = procedure(var g: game; userData: Pointer); stdcall;
pmyCallbackInfo = ^myCallbackInfo;
myCallbackInfo = record
Grid: TStringGrid;
FirstTime: Boolean;
end;
procedure myCallback(var g: game; userData: Pointer); stdcall;
var
row: Integer;
begin
Grid := pmyCallbackInfo(userData).Grid;
// add a new row only if the initial non-fixed row is already filled...
if pmyCallbackInfo(userData).FirstTime then
pmyCallbackInfo(userData).FirstTime := False
else
Grid.RowCount := Grid.RowCount + 1;
row := Grid.RowCount - 1;
Grid.Cells[0, row] := g.nazwa;
Grid.Cells[1, row] := g.wydawca;
Grid.Cells[2, row] := IntToStr(g.rokwyd);
Grid.Cells[3, row] := g.gatunek1;
Grid.Cells[4, row] := g.gatunek2;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
DLLHandle : THandle;
WyswietlListe : procedure(callback: gameCallback; userData: Pointer); stdcall;
info: myCallbackInfo;
begin
// clear the TStringGrid. However, it has an odd quirk
// that it requires at least 1 non-fixed row at all times...
//
StringGrid1.RowCount := StringGrid1.FixedRows + 1;
StringGrid1.Rows[StringGrid1.RowCount - 1].Clear;
DLLHandle := LoadLibrary('BibliotekaDLL.dll');
if DLLHandle = 0 then raise Exception.Create(...);
try
#WyswietlListe := GetProcAddress(DLLHandle, 'WyswietlListe');
if not Assigned(WyswietlListe) then raise Exception.Create('Nie Można Znaleźć Procedury w Bibliotece!');
info.Grid := StringGrid1;
info.FirstTime := True;
WyswietlListe(#myCallback, #info);
finally
FreeLibrary(DLLHandle);
end;
end;

¿How can I send and recieve strings from tidtcpclient and tidtcpserver and to create a chat?

im new at delphi languaje and im using Rad Studio to make apps work on every device with oune single programming. Right now Im supposed to make a chat using sockets, I made a chat for windows only using tclientsocket and tserversocket using the next code, what Im trying to do is make the exact thing but using tidtcpclient and tidtcpserver instead of tclientsocket and tserversocket
Server:
unit Server;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Win.ScktComp, Vcl.StdCtrls;
type
TServidor = class(TForm)
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
ServerSocket1: TServerSocket;
Memo1: TMemo;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Servidor: TServidor;
Str: String;
implementation
{$R *.dfm}
procedure TServidor.Button1Click(Sender: TObject);
var
i: integer;
begin
Str:=Edit1.Text;//Take the string (message) sent by the server
Memo1.Text:=Memo1.Text+'yo: '+Str+#13#10;//Adds the message to the memo box
Edit1.Text:='';//Clears the edit box
//Sends the messages to all clients connected to the server
for i:=0 to ServerSocket1.Socket.ActiveConnections-1 do
ServerSocket1.Socket.Connections[i].SendText(str);//Sent
end;
procedure TServidor.Button2Click(Sender: TObject);
begin
if(ServerSocket1.Active = False)//The button caption is ‘Start’
then
begin
ServerSocket1.Active := True;//Activates the server socket
Memo1.Text:=Memo1.Text+'Servidor en linea'+#13#10;
Button2.Caption:='Apagar';//Set the button caption
end
else//The button caption is ‘Stop’
begin
ServerSocket1.Active := False;//Stops the server socket
Memo1.Text:=Memo1.Text+'Servidor fuera de linea'+#13#10;
Button2.Caption:='Encender';
//If the server is closed, then it cannot send any messages
Button1.Enabled:=false;//Disables the “Send” button
Edit1.Enabled:=false;//Disables the edit box
end;
end;
procedure TServidor.ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Socket.SendText('Conectado');//Sends a message to the client
//If at least a client is connected to the server, then the server can communicate
//Enables the Send button and the edit box
Button1.Enabled:=true;
Edit1.Enabled:=true;
end;
procedure TServidor.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
Begin
//The server cannot send messages if there is no client connected to it
if ServerSocket1.Socket.ActiveConnections-1=0 then
begin
Button1.Enabled:=false;
Edit1.Enabled:=false;
end;
end;
procedure TServidor.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
Begin
//Read the message received from the client and add it to the memo text
// The client identifier appears in front of the message
Memo1.Text:=Memo1.Text+'Cliente'+IntToStr(Socket.SocketHandle)+' :'+Socket.ReceiveText+#13#10;
end;
end.
Client
unit Server;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Win.ScktComp, Vcl.StdCtrls;
type
TServidor = class(TForm)
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
ServerSocket1: TServerSocket;
Memo1: TMemo;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Servidor: TServidor;
Str: String;
implementation
{$R *.dfm}
procedure TServidor.Button1Click(Sender: TObject);
var
i: integer;
begin
Str:=Edit1.Text;//Take the string (message) sent by the server
Memo1.Text:=Memo1.Text+'yo: '+Str+#13#10;//Adds the message to the memo box
Edit1.Text:='';//Clears the edit box
//Sends the messages to all clients connected to the server
for i:=0 to ServerSocket1.Socket.ActiveConnections-1 do
ServerSocket1.Socket.Connections[i].SendText(str);//Sent
end;
procedure TServidor.Button2Click(Sender: TObject);
begin
if(ServerSocket1.Active = False)//The button caption is ‘Start’
then
begin
ServerSocket1.Active := True;//Activates the server socket
Memo1.Text:=Memo1.Text+'Servidor en linea'+#13#10;
Button2.Caption:='Apagar';//Set the button caption
end
else//The button caption is ‘Stop’
begin
ServerSocket1.Active := False;//Stops the server socket
Memo1.Text:=Memo1.Text+'Servidor fuera de linea'+#13#10;
Button2.Caption:='Encender';
//If the server is closed, then it cannot send any messages
Button1.Enabled:=false;//Disables the “Send” button
Edit1.Enabled:=false;//Disables the edit box
end;
end;
procedure TServidor.ServerSocket1ClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Socket.SendText('Conectado');//Sends a message to the client
//If at least a client is connected to the server, then the server can communicate
//Enables the Send button and the edit box
Button1.Enabled:=true;
Edit1.Enabled:=true;
end;
procedure TServidor.ServerSocket1ClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
Begin
//The server cannot send messages if there is no client connected to it
if ServerSocket1.Socket.ActiveConnections-1=0 then
begin
Button1.Enabled:=false;
Edit1.Enabled:=false;
end;
end;
procedure TServidor.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
Begin
//Read the message received from the client and add it to the memo text
// The client identifier appears in front of the message
Memo1.Text:=Memo1.Text+'Cliente'+IntToStr(Socket.SocketHandle)+' :'+Socket.ReceiveText+#13#10;
end;
end.
A straight translation of the server code would look like this:
unit Server;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, IdTCPServer, IdContext;
type
TServidor = class(TForm)
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
IdTCPServer1: TIdTCPServer;
Memo1: TMemo;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure IdTCPServer1Connect(AContext: TIdContext);
procedure IdTCPServer1Disconnect(AContext: TIdContext);
procedure IdTCPServer1Execute(AContext: TIdContext);
private
{ Private declarations }
procedure UpdateButtons;
public
{ Public declarations }
end;
var
Servidor: TServidor;
implementation
{$R *.dfm}
procedure TServidor.Button1Click(Sender: TObject);
var
i: integer;
list: TIdContextList;
Str: String;
begin
Str := Edit1.Text;//Take the string (message) sent by the server
Memo1.Lines.Add('yo: ' + Str); //Adds the message to the memo box
Edit1.Text := '';//Clears the edit box
//Sends the messages to all clients connected to the server
list := IdTCPServer1.Contexts.LockList;
try
for i := 0 to list.Count-1 do
begin
try
TIdContext(list[i]).Connection.IOHandler.WriteLn(str);//Sent
except
end;
end;
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TServidor.Button2Click(Sender: TObject);
begin
if not IdTCPServer1.Active //The button caption is ‘Start’
then
begin
IdTCPServer1.Active := True;//Activates the server socket
Memo1.Lines.Add('Servidor en linea');
Button2.Caption := 'Apagar';//Set the button caption
end
else//The button caption is ‘Stop’
begin
IdTCPServer1.Active := False;//Stops the server socket
Memo1.Lines.Add('Servidor fuera de linea');
Button2.Caption := 'Encender';
//If the server is closed, then it cannot send any messages
Button1.Enabled := false;//Disables the “Send” button
Edit1.Enabled := false;//Disables the edit box
end;
end;
procedure TServidor.UpdateButtons;
var
list: TIdContextList;
begin
list := IdTCPServer1.Contexts.LockList;
try
Button1.Enabled := list.Count > 0;
Edit1.Enabled := Button1.Enabled;
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TServidor.IdTCPServer1Connect(AContext: TIdContext);
begin
AContext.Connection.IOHandler.WriteLn('Conectado');//Sends a message to the client
//If at least a client is connected to the server, then the server can communicate
//Enables the Send button and the edit box
TThread.Queue(nil, UpdateButtons);
end;
procedure TServidor.IdTCPServer1Disconnect(AContext: TIdContext);
begin
//The server cannot send messages if there is no client connected to it
TThread.Queue(nil, UpdateButtons);
end;
procedure TServidor.IdTCPServer1Execute(AContext: TIdContext);
var
Str: String;
begin
//Read the message received from the client and add it to the memo text
// The client identifier appears in front of the message
Str := 'Cliente '+ AContext.Binding.PeerIP + ' :' + AContext.Connection.IOHandler.ReadLn;
TThread.Queue(nil,
procedure
begin
Memo1.Lines.Add(Str);
end
);
end;
end.
This is not the safest way to implement a server, though. In particular, broadcasting messages to client in the Button1Click() procedure. A safer approach would look more like this instead:
unit Server;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, IdTCPServer, IdContext;
type
TServidor = class(TForm)
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
IdTCPServer1: TIdTCPServer;
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure IdTCPServer1Connect(AContext: TIdContext);
procedure IdTCPServer1Disconnect(AContext: TIdContext);
procedure IdTCPServer1Execute(AContext: TIdContext);
private
{ Private declarations }
procedure UpdateButtons;
public
{ Public declarations }
end;
var
Servidor: TServidor;
implementation
{$R *.dfm}
uses
IdTCPConnection, IdYarn, IdThreadSafe;
type
TMyContext = class(TIdServerContext)
private
Queue: TIdThreadSafeStringList;
QueuePending: Boolean;
public
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
procedure AddToQueue(const s: string);
procedure SendQueue;
end;
constructor TMyContext.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
Queue := TIdThreadSafeStringList.Create;
end;
destructor TMyContext.Destroy;
begin
Queue.Free;
inherited;
end;
procedure TMyContext.AddToQueue(const s: string);
var
list: TStringList;
begin
list := Queue.Lock;
try
list.Add(s);
QueuePending := True;
finally
Queue.Unlock;
end;
end;
procedure TMyContext.SendQueue;
var
list: TStringList;
tmpList: TStringList;
i: Integer;
begin
if not QueuePending then Exit;
tmp := nil;
try
list := Queue.Lock;
try
if list.Count = 0 then
begin
QueuePending := False;
Exit;
end;
tmpList := TStringList.Create;
tmpList.Assign(list);
list.Clear;
QueuePending := False;
finally
Queue.Unlock;
end;
for i := 0 to tmpList.Count-1 do
Connection.IOHandler.WriteLn(tmpList[i]);
finally
tmpList.Free;
end;
end;
procedure TServidor.FormCreate(Sender: TObject);
begin
IdTCPServer1.ContextClass := TMyContext;
end;
procedure TServidor.Button1Click(Sender: TObject);
var
i: integer;
list: TIdContextList;
Str: String;
begin
Str := Edit1.Text;//Take the string (message) sent by the server
Memo1.Lines.Add('yo: ' + Str); //Adds the message to the memo box
Edit1.Text := '';//Clears the edit box
//Sends the messages to all clients connected to the server
list := IdTCPServer1.Contexts.LockList;
try
for i := 0 to list.Count-1 do
TMyContext(list[i]).AddToQueue(str);//Sent
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TServidor.Button2Click(Sender: TObject);
begin
if not IdTCPServer1.Active //The button caption is ‘Start’
then
begin
IdTCPServer1.Active := True;//Activates the server socket
Memo1.Lines.Add('Servidor en linea');
Button2.Caption := 'Apagar';//Set the button caption
end
else//The button caption is ‘Stop’
begin
IdTCPServer1.Active := False;//Stops the server socket
Memo1.Lines.Add('Servidor fuera de linea');
Button2.Caption := 'Encender';
//If the server is closed, then it cannot send any messages
Button1.Enabled := false;//Disables the “Send” button
Edit1.Enabled := false;//Disables the edit box
end;
end;
procedure TServidor.UpdateButtons;
var
list: TIdContextList;
begin
list := IdTCPServer1.Contexts.LockList;
try
Button1.Enabled := list.Count > 0;
Edit1.Enabled := Button1.Enabled;
finally
IdTCPServer1.Contexts.UnlockList;
end;
end;
procedure TServidor.IdTCPServer1Connect(AContext: TIdContext);
begin
AContext.Connection.IOHandler.WriteLn('Conectado');//Sends a message to the client
//If at least a client is connected to the server, then the server can communicate
//Enables the Send button and the edit box
TThread.Queue(nil, UpdateButtons);
end;
procedure TServidor.IdTCPServer1Disconnect(AContext: TIdContext);
begin
//The server cannot send messages if there is no client connected to it
TThread.Queue(nil, UpdateButtons);
end;
procedure TServidor.IdTCPServer1Execute(AContext: TIdContext);
var
LContext: TMyContext;
Str: String;
begin
LContext := TMyContext(AContext);
//send pending messages from the server
LContext.SendQueue;
//check for a message received from the client
if AContext.IOHandler.InputBufferIsEmpty then
begin
AContext.IOHandler.CheckForDataOnSource(100);
AContext.IOHandler.CheckForDisconnect;
if AContext.IOHandler.InputBufferIsEmpty then Exit;
end;
//read the message received from the client and add it to the memo text
// The client identifier appears in front of the message
Str := 'Cliente '+ AContext.Binding.PeerIP + ' :' + AContext.Connection.IOHandler.ReadLn;
TThread.Queue(nil,
procedure
begin
Memo1.Lines.Add(Str);
end
);
end;
end.
As for the client, you did not show your client code (you showed your server code twice), but here is what a client implementation could look like (note that this is not the best way to implement a client that can receive unsolicited server messages, though):
unit Client;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, IdTCPClient;
type
TCliente = class(TForm)
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
IdTCPClient1: TIdTCPClient;
Memo1: TMemo;
Timer1: TTimer;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
procedure CloseClient;
public
{ Public declarations }
end;
var
Cliente: TCliente;
implementation
{$R *.dfm}
procedure TCliente.Button1Click(Sender: TObject);
var
i: integer;
Str: String;
begin
Str := Edit1.Text;//Take the string (message) sent by the client
Memo1.Lines.Add('yo: '+Str);//Adds the message to the memo box
Edit1.Text := '';//Clears the edit box
//Sends the message to the server
try
IdTCPClient1.IOHandler.WriteLn(str);//Sent
except
CloseClient;
end;
end;
procedure TServidor.Button2Click(Sender: TObject);
begin
if not IdTCPClient1.Connected //The button caption is ‘Start’
then
begin
IdTCPClient1.Connect;//Activates the client socket
Memo1.Lines.Add('Cliente en linea');
Button2.Caption := 'Apagar';//Set the button caption
//Enables the Send button and the edit box
Button1.Enabled := true;
Edit1.Enabled := true;
Timer1.Enabled := True;
end
else//The button caption is ‘Stop’
begin
CloseClient;
end;
end;
procedure TCliente.CloseClient;
begin
IdTCPClient1.Disconnect;//Stops the client socket
Memo1.Lines.Add('Cliente fuera de linea');
Button2.Caption := 'Encender';
//If the client is closed, then it cannot send any messages
Button1.Enabled := false;//Disables the “Send” button
Edit1.Enabled := false;//Disables the edit box
Timer1.Enabled := false;
end;
procedure TCliente.Timer1Timer(Sender: TObject);
begin
try
//check for a message from the server
if IdTCPClient1.IOHandler.InputBufferIsEmpty then
begin
IdTCPClient1.IOHandler.CheckForDataOnSource(10);
IdTCPClient1.IOHandler.CheckForDisconnect;
if IdTCPClient1.IOHandler.InputBufferIsEmpty then Exit;
end;
//Read the message received from the server and add it to the memo text
// The client identifier appears in front of the message
Memo1.Lines.Add('Servidor :' + IdTCPClient1.IOHandler.ReadLn);
except
CloseClient;
end;
end;
end.

Event when all mdi forms are closed

Guys, I'd like if anyone knows any event or method that I can intercept when all MDI forms were closed.
Example:
I want to implement an event in my main form where when I close all MDI forms, such an event was triggered.
Grateful if anyone can help.
MDI child forms (in fact any form), while being destroyed, will notify the main form. You can use this notification mechanism. Example:
type
TForm1 = class(TForm)
..
protected
procedure Notification(AComponent: TComponent; Operation: TOperation);
override;
..
procedure TForm1.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if (Operation = opRemove) and (AComponent is TForm) and
(TForm(AComponent).FormStyle = fsMDIChild) and
(MDIChildCount = 0) then begin
// do work
end;
end;
Catch the WM_MDIDESTROY message send to the MDI client window:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FOldClientWndProc: TFarProc;
procedure NewClientWndProc(var Message: TMessage);
end;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
if FormStyle = fsMDIForm then
begin
HandleNeeded;
FOldClientWndProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
SetWindowLong(ClientHandle, GWL_WNDPROC,
Integer(MakeObjectInstance(NewClientWndProc)));
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
SetWindowLong(ClientHandle, GWL_WNDPROC, Integer(FOldClientWndProc));
end;
procedure TForm1.NewClientWndProc(var Message: TMessage);
begin
if Message.Msg = WM_MDIDESTROY then
if MDIChildCount = 1 then
// do work
with Message do
Result := CallWindowProc(FOldClientWndProc, ClientHandle, Msg, WParam,
LParam);
end;
You can have the MainForm assign an OnClose or OnDestroy event handler to each MDI child it creates. Each time an MDI client is closed/destroyed, the handler can check if any more MDI child forms are still open, and if not then do whatever it needs to do.
procedure TMainForm.ChildClosed(Sender: TObject; var Action: TCloseAction);
begin
Action := caFree;
// the child being closed is still in the MDIChild list as it has not been freed yet...
if MDIChildCount = 1 then
begin
// do work
end;
end;
Or:
const
APPWM_CHECK_MDI_CHILDREN = WM_APP + 1;
procedure TMainForm.ChildDestroyed(Sender: TObject);
begin
PostMessage(Handle, APPWM_CHECK_MDI_CHILDREN, 0, 0);
end;
procedure TMainForm.WndProc(var Message: TMessage);
begin
if Message.Msg = APPWM_CHECK_MDI_CHILDREN then
begin
if MDIChildCount = 0 then
begin
// do work
end;
Exit;
end;
inherited;
end;

Delphi application form shows instead of hiding at startup

I have a program where it will not start minimized and shows a very small window on the dekstop.
Image: http://i.imgur.com/j8xus.jpg
Code:
program:
program Project4;
uses
Forms,
Unit4 in 'Unit4.pas' {Form4};
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := false;
Application.ShowMainForm:=false;
Application.CreateForm(TForm4, Form4);
Application.Run;
end.
unit:
unit Unit4;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, AppEvnts, ExtCtrls, Menus;
type
TForm4 = class(TForm)
TrayIcon1: TTrayIcon;
ApplicationEvents1: TApplicationEvents;
PopupMenu1: TPopupMenu;
Exit1: TMenuItem;
procedure TrayIcon1DblClick(Sender: TObject);
procedure ApplicationEvents1Minimize(Sender: TObject);
procedure ApplicationEvents1Restore(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormCreate(Sender: TObject);
procedure Exit1Click(Sender: TObject);
private
{ Private declarations }
fCanClose: Boolean;
public
{ Public declarations }
end;
var
Form4: TForm4;
implementation
{$R *.dfm}
procedure TForm4.ApplicationEvents1Minimize(Sender: TObject);
begin
Hide();
WindowState := wsMinimized;
end;
procedure TForm4.ApplicationEvents1Restore(Sender: TObject);
begin
Show();
WindowState := wsNormal;
application.Bringtofront;
end;
procedure TForm4.Exit1Click(Sender: TObject);
begin
fcanclose:=true;
close;
end;
procedure TForm4.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
if not fCanClose then
begin
hide;
windowstate:=wsminimized;
CanClose:=false;
end
else
CanCLose:=True;
end;
procedure TForm4.FormCreate(Sender: TObject);
begin
fCanClose:=FALSE;
end;
procedure TForm4.TrayIcon1DblClick(Sender: TObject);
begin
if (windowstate = wsminimized) then
begin
Show;
windowstate := wsnormal;
application.BringToFront;
end
else
begin
hide;
windowstate:=wsminimized;
end;
end;
end.
I created your project and had the same problems until I changed the following line of code to True:
Application.MainFormOnTaskbar := True;
Now the app seems to work just fine without an minimizing to the bottom left corner of the desktop before it is hidden.

How do I save the contents of TWebBrowser, including user-entered form values?

is it possible to save entire document loaded in Webbrowser (in Delphi) as a ordinary HTML file with new values (I mean values entered by user in html's forms this document)?
I need this for reading this HTML document with all values next time when application will be used.
Sure this is possible!
Small demo App, make a new vcl forms application, drop a TWebBrowser, a TButton and a TMemo on your form and use this code (don't forget to bind OnCreate for the Form and OnClick for the Button)
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, OleCtrls, SHDocVw, StdCtrls,mshtml, ActiveX;
type
TForm1 = class(TForm)
WebBrowser1: TWebBrowser;
Button1: TButton;
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//code snagged from about.com
procedure WBLoadHTML(WebBrowser: TWebBrowser; HTMLCode: string) ;
var
sl: TStringList;
ms: TMemoryStream;
begin
WebBrowser.Navigate('about:blank') ;
while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do
Application.ProcessMessages;
if Assigned(WebBrowser.Document) then
begin
sl := TStringList.Create;
try
ms := TMemoryStream.Create;
try
sl.Text := HTMLCode;
sl.SaveToStream(ms) ;
ms.Seek(0, 0) ;
(WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms)) ;
finally
ms.Free;
end;
finally
sl.Free;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Doc : IHtmlDocument2;
begin
Doc := WebBrowser1.Document as IHtmlDocument2;
Memo1.Lines.Text := Doc.body.innerHTML;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Html : String;
begin
Html := 'change value of input and press Button1 to changed DOM<br/><input id="myinput" type="text" value="orgval"></input>';
WBLoadHTML(WebBrowser1, Html);
end;
end.
Output:
EDIT
As mjn pointed out, the values of password type inputs will not be shown.
You can still can get their value though:
add these 2 lines to Button1.Click and change html
OnCreate:
Html := 'change value of input and press Button1 to changed DOM<br/><input id="myinput" type="password" value="orgval"></input>';
OnClick:
El := (Doc as IHtmlDocument3).getElementById('myinput') as IHtmlInputElement;
Memo1.Lines.Add(Format('value of password field = %s', [El.value]))