"Available Form:". Original Delphi Frames with Original unit - delphi

Problem:
How can I load frame in Form1 or sample container in form ?
FindClass or GetClass is only locality for main form appl-n
I need (maybe) string globaly elemental for TFrameClass, next code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls, Vcl.ExtCtrls;
type
TFrameClass = class of TFrame;
type
TForm1 = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
FFrame: TFrame;
function StrShowFrame(FrameClassName: string;
ParentPanel: TWinControl): Boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses Base1Frame, Base2Frame, Base3Frame;
function TForm1.StrShowFrame(FrameClassName: string;
ParentPanel: TWinControl): Boolean;
var
FrameClass: TClass;
// Current Frame (FrameName)
FrameName: string;
begin
Result := False;
??? GetClass is only locality for main form in appl-n
FrameClass := GetClass(FrameClassName);
if FrameClass = nil then
begin
ShowMessageFmt('Class %s not registered', [FrameClassName]);
Result := False;
Exit;
end;
try
begin
LockWindowUpdate(ParentPanel.Handle);
if Assigned(FFrame) then
if FFrame.ClassType = FrameClass then
begin
Result := True;
Exit;
end
else
FFrame.Destroy; // del previus FrameClass
try
FFrame := TFrameClass(FrameClass).Create(nil);
except
on E:Exception do
begin
Result := True;
E.Create(E.Message);
FFrame := nil;
Exit;
end;
end;
FrameName:= FrameClassName;
Delete(FrameName, 1, 1); // T-...
FFrame.Name := Concat(FrameName, '1');
FFrame.Parent := ParentPanel;
FFrame.Align := alClient;
end;
finally
LockWindowUpdate(0);
end;
Result := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
StrShowFrame('TFr_Base1', Panel1);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
if FFrame <> nil then
FFrame.Free
else
ShowMessage('Class not activ');
except
end;
end;
end.
How can I load frame in Form1 or sample container in form ?
FindClass or GetClass is only locality for main form appl-n
I need (maybe) string globaly elemental for TFrameClass.

GetClass() and FindClass() are not local to the MainForm, they are global to the entire RTL as a whole. Any unit can call RegisterClass() and have that class be accessible to any other unit that shares the same instance of the RTL. That last part is important. A DLL cannot register a class that the EXE uses (and vice versa), unless both projects are compiled with Runtime Packages enabled so they share a single RTL instance.

Related

How to modify the text being pasted?

I'm trying to modify the text being pasted inside a TEdit descendant.
When the user paste some text, I want to replace all 'X' chars with an 'Y', without modifying the actual clipboard text content.
I've intercepted the WM_PASTE message, but I'm not aware about any "clean" way to change the text that's being pasted into the control.
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
TMyEdit = class(Vcl.StdCtrls.TEdit)
private
procedure WMPaste(var Msg: TWMPaste); message WM_PASTE;
end;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
Clipbrd;
procedure TMyEdit.WMPaste(var Msg: TWMPaste);
begin
inherited;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Edt : TMyEdit;
begin
Edt := TMyEdit.Create(Self);
Edt.Top := 10;
Edt.Left := 10;
Edt.Parent := Self;
end;
end.
The only working way I've found is to temporarly replace the clipboard content, but I'm looking for a cleaner solution (if there's one...).
procedure TMyEdit.WMPaste(var Msg: TWMPaste);
var
PrevClipboardText : string;
begin
if(IsClipboardFormatAvailable(CF_TEXT)) then
begin
PrevClipboardText := Clipboard.AsText;
try
Clipboard.AsText := StringReplace(Clipboard.AsText, 'X', 'Y', [rfReplaceAll]);
inherited;
finally
Clipboard.AsText := PrevClipboardText;
end;
end else
begin
inherited;
end;
end;
Why not do the obvious thing?
procedure TEdit.WMPaste(var Msg: TWMPaste);
begin
SelText := F(Clipboard.AsText);
end;
where F is your string-transforming function.

Modal dialog does not return focus to application

I have a custom control derived from TPanel named TTestCtrl. It holds a TImage32 (from Graphics32).
When the user double clicks on the image, I show a message. The problem is that after I close the message, the focus is not returned back to the main application. So, the first click, no matter what I click on in the main app/main form, is lost.
Strange thing: If I call the Mesaj() procedure not from the TTestCtrl but from the main form, it works (the first click is not lost anymore):
unit DerivedControl;
interface
uses
System.SysUtils, System.Classes, Vcl.Controls, Vcl.ExtCtrls, Vcl.Dialogs, Vcl.Forms, GR32, GR32_Image;
type
TTestCtrl = class(TPanel)
private
Img: TImage32;
protected
procedure ChromaDblClick(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
published
end;
procedure Mesaj(const MessageText, Title: string);
implementation
procedure Mesaj(const MessageText, Title: string);
begin
{$IFDEF MSWINDOWS}
Application.MessageBox(PChar(MessageText), PChar(Title), 0) { 'Title' will appear in window's caption }
{$ELSE}
MessageDlg(MessageText, mtInformation, [mbOk], 0);
{$ENDIF}
end;
constructor TTestCtrl.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 200;
Height := 86;
Img := TImage32.Create(Self);
Img.Parent := Self;
Img.Align := alClient;
Img.OnDblClick := ChromaDblClick;
end;
procedure TTestCtrl.ChromaDblClick(Sender: TObject);
begin
Mesaj('Caption', 'From derived control'); // focus lost
end;
end.
The simple/minimal application below is the tester:
unit TesterForm;
interface
uses
System.SysUtils, System.Classes, Vcl.StdCtrls, Vcl.Samples.Spin, Vcl.Controls, vcl.Forms, DerivedControl;
type
TfrmTester = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
public
end;
var
frmTester: TfrmTester;
implementation
{$R *.dfm}
var
Ctrl: TTestCtrl;
procedure TfrmTester.FormCreate(Sender: TObject);
begin
Ctrl := TTestCtrl.Create(Self);
Ctrl.Parent := Self;
end;
procedure TfrmTester.Button1Click(Sender: TObject);
begin
Mesaj('Caption', 'From main form'); // works
end;
end.
Try this :
procedure TTestCtrl.ChromaDblClick(Sender: TObject);
var F : TcustomForm;
begin
Mesaj('Caption', 'From derived control'); // focus lost
F := GetParentForm(Self);
if Assigned(F) then F.BringToFront;
end;

Delphi FireDAC TFDQuery event 'AfterOpen' never executes

I'm trying to execute an sql query asynchronously. I've checked the example code from http://docwiki.embarcadero.com/RADStudio/XE5/en/Asynchronous_Execution_(FireDAC)
and also the example project from directory
..Samples\Object Pascal\Database\FireDAC\Samples\Comp Layer\TFDQuery\ExecSQL\Async
and I think I got the logic inside. But there is one problem - the event QueryAfterOpen never executes and my TDataSource remains always Nil (because it gets Nil inside QueryBeforeOpen - this event executes always). This is all the code from my unit :
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, FireDAC.Stan.Intf,
FireDAC.Stan.Option, FireDAC.Stan.Error, FireDAC.UI.Intf, FireDAC.Phys.Intf,
FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Stan.Async, FireDAC.Phys,
FireDAC.VCLUI.Wait, FireDAC.Stan.Param, FireDAC.DatS, FireDAC.DApt.Intf, FireDAC.DApt,
Vcl.StdCtrls, Data.DB, FireDAC.Comp.DataSet, FireDAC.Comp.Client,
FireDAC.Phys.MySQLDef, FireDAC.Phys.MySQL;
type
TForm1 = class(TForm)
Button1: TButton;
FDPhysMySQLDriverLink1: TFDPhysMySQLDriverLink;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Query1BeforeOpen(DataSet: TDataSet);
procedure Query1AfterOpen(DataSet: TDataSet);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
Connection1: TFDConnection;
Query1: TFDQuery;
DataSource1: TDataSource;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
QueryFinished: Boolean;
begin
with Query1 do begin
SQL.Text := 'SELECT field1 FROM test_table WHERE idpk=1';
AfterOpen := Query1AfterOpen;
BeforeOpen := Query1BeforeOpen;
ResourceOptions.CmdExecMode := amAsync;
QueryFinished := False;
Open;
repeat
Sleep(100);
if Command.State = csPrepared then begin
// A command is prepared. A result set is not accessible.
// TmpInteger := Query1.FieldByName('field1').AsInteger;
end
else if Command.State = csOpen then begin // A command execution
// is finished. A result set is accessible and not yet fully fetched.
if DataSource1.DataSet <> Nil then begin
// this code never executes because Query1AfterOpen never executes and
// DataSource1.DataSet remains always Nil !!!
QueryFinished := True;
end;
end;
until ((QueryFinished) OR (DataSource1.DataSet <> Nil));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
SQLConnParams: string;
begin
SQLConnParams := ''; // sql connection parameters removed from here from security
// issues, assume they are correct
Connection1 := TFDConnection.Create(Nil);
Connection1.Params.Text := SQLConnParams;
Query1 := TFDQuery.Create(Nil);
Query1.Connection := Connection1;
DataSource1 := TDataSource.Create(Nil);
DataSource1.DataSet := Query1;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DataSource1.Free;
Query1.Free;
Connection1.Free;
end;
procedure TForm1.Query1AfterOpen(DataSet: TDataSet);
begin
DataSource1.DataSet := Query1;
Query1.AfterOpen := Nil;
//Query1.ResourceOptions.CmdExecMode := amBlocking;
end;
procedure TForm1.Query1BeforeOpen(DataSet: TDataSet);
begin
DataSource1.DataSet := Nil;
end;
end.
Apparently the code inside the repeat .. until .. loop is infinite unless someone terminates the program. What am I missing in order to execute the code inside Query1AfterOpen (or use another event instead) so I can access the result set after the TFDQuery has finished working ?
Those asynchronous events are synchronized with the main thread via the message loop. As long as you stay inside the Button1Click event no new messages can be handled. Thus the AfterOpen event is stuck inside the message loop.
I don't know what you are trying to achieve, but you should consider placing the relevant code in the AfterOpen event. The repeat-until clause somehow counterfeits the purpose of that async execution.

Delphi XE8 unknown memory leaks in simple DataSnap client and server app

I have created a simple DataSnap client/server application with the wizard in Delphi XE8 using the echostring and reversestring sample methods. When I put "ReportMemoryLeaksOnShutdown := True" in the Server dpr and call the echostring and/or reversestring methods from the client the result is good but when I close the server application (after closing the client) I always get 2 or more unknown memory leaks. Is this a known bug which I can't find on the internet or is there a solution?
Server code:
unit ServerMethodsUnit;
interface
uses System.SysUtils, System.Classes, System.Json,
Datasnap.DSServer, Datasnap.DSAuth, DataSnap.DSProviderDataModuleAdapter;
type
{$METHODINFO ON}
TServerMethods = class(TDataModule)
private
{ Private declarations }
public
{ Public declarations }
function EchoString(Value: string): string;
function ReverseString(Value: string): string;
end;
{$METHODINFO OFF}
implementation
{%CLASSGROUP 'FMX.Controls.TControl'}
{$R *.dfm}
uses System.StrUtils;
function TServerMethods.EchoString(Value: string): string;
begin
Result := Value;
end;
function TServerMethods.ReverseString(Value: string): string;
begin
Result := System.StrUtils.ReverseString(Value);
end;
end.
dfm
object ServerContainer: TServerContainer
OldCreateOrder = False
Height = 271
Width = 415
object DSServer1: TDSServer
Left = 96
Top = 11
end
object DSTCPServerTransport1: TDSTCPServerTransport
Server = DSServer1
Filters = <>
Left = 96
Top = 73
end
object DSServerClass1: TDSServerClass
OnGetClass = DSServerClass1GetClass
Server = DSServer1
Left = 200
Top = 11
end
end
dfm project file
program DataSnap_Server;
uses
FMX.Forms,
Web.WebReq,
IdHTTPWebBrokerBridge,
ServerMainForm in 'ServerMainForm.pas' {Form2},
ServerMethodsUnit in 'ServerMethodsUnit.pas' {ServerMethods: TDataModule},
ServerContainerUnit in 'ServerContainerUnit.pas' {ServerContainer: TDataModule};
{$R *.res}
begin
ReportMemoryLeaksOnShutdown := True;
Application.Initialize;
Application.CreateForm(TForm2, Form2);
Application.CreateForm(TServerContainer, ServerContainer);
Application.Run;
end.
client side code generated source
//
// Created by the DataSnap proxy generator.
// 14-5-2015 22:45:56
//
unit ClientClassesUnit;
interface
uses System.JSON, Data.DBXCommon, Data.DBXClient, Data.DBXDataSnap, Data.DBXJSON, Datasnap.DSProxy, System.Classes, System.SysUtils, Data.DB, Data.SqlExpr, Data.DBXDBReaders, Data.DBXCDSReaders, Data.DBXJSONReflect;
type
TServerMethodsClient = class(TDSAdminClient)
private
FEchoStringCommand: TDBXCommand;
FReverseStringCommand: TDBXCommand;
public
constructor Create(ADBXConnection: TDBXConnection); overload;
constructor Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean); overload;
destructor Destroy; override;
function EchoString(Value: string): string;
function ReverseString(Value: string): string;
end;
implementation
function TServerMethodsClient.EchoString(Value: string): string;
begin
if FEchoStringCommand = nil then
begin
FEchoStringCommand := FDBXConnection.CreateCommand;
FEchoStringCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FEchoStringCommand.Text := 'TServerMethods.EchoString';
FEchoStringCommand.Prepare;
end;
FEchoStringCommand.Parameters[0].Value.SetWideString(Value);
FEchoStringCommand.ExecuteUpdate;
Result := FEchoStringCommand.Parameters[1].Value.GetWideString;
end;
function TServerMethodsClient.ReverseString(Value: string): string;
begin
if FReverseStringCommand = nil then
begin
FReverseStringCommand := FDBXConnection.CreateCommand;
FReverseStringCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FReverseStringCommand.Text := 'TServerMethods.ReverseString';
FReverseStringCommand.Prepare;
end;
FReverseStringCommand.Parameters[0].Value.SetWideString(Value);
FReverseStringCommand.ExecuteUpdate;
Result := FReverseStringCommand.Parameters[1].Value.GetWideString;
end;
constructor TServerMethodsClient.Create(ADBXConnection: TDBXConnection);
begin
inherited Create(ADBXConnection);
end;
constructor TServerMethodsClient.Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean);
begin
inherited Create(ADBXConnection, AInstanceOwner);
end;
destructor TServerMethodsClient.Destroy;
begin
FEchoStringCommand.DisposeOf;
FReverseStringCommand.DisposeOf;
inherited;
end;
end.
Own source
unit ClientMainForm;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
ClientModuleUnit;
procedure TForm1.Button1Click(Sender: TObject);
begin
Label1.Caption := ClientModule.ServerMethodsClient.EchoString(Edit1.Text);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Label1.Caption := ClientModule.ServerMethodsClient.ReverseString(Edit1.Text);
end;
end.
Memory leak looks like always exist, or, we doing something wrong.
What I checked:
I move all server app code into the one unit.
I try server app without FMX - with VCL.
I try to create TDSServer, TDSTCPServerTransport, TDSServerClass in runtime with parents Self and Nil.
I try with TServerMethod class owner TPersistance and TComponent (Delphi help says to use it).
I try with compiled server app as 32 bit and 64 bit application in Delphi XE7 Update 1 and in Delphi XE8.
EurekaLog 7.2.2 cannot catch details about memory leak also.
For avoid catching Access Violation by EurekaLog need to use DSServer1.Stop before exit.
As we could see Access Violation when you using EurekaLog happens there
Basically it's in
System.TObject.InheritsFrom(???)
System._IsClass($64AE4E0,TDSServerTransport)
Datasnap.DSCommonServer.TDSCustomServer.StopTransports
Datasnap.DSCommonServer.TDSCustomServer.Stop
Datasnap.DSServer.TDSServer.Stop
Datasnap.DSServer.TDSServer.Destroy
System.TObject.Free
System.Classes.TComponent.DestroyComponents
System.Classes.TComponent.Destroy
System.Classes.TDataModule.Destroy
System.TObject.Free
System.Classes.TComponent.DestroyComponents
FMX.Forms.DoneApplication
System.SysUtils.DoExitProc
System._Halt0
:00408da8 TObject.InheritsFrom + $8
Server app:
unit ufmMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Datasnap.DSServer, Datasnap.DSTCPServerTransport, Datasnap.DSAuth, DataSnap.DSProviderDataModuleAdapter, Datasnap.DSCommonServer,
IPPeerServer;
type
{$METHODINFO ON}
TServerMethods = class(TComponent)
private
{ Private declarations }
public
{ Public declarations }
function EchoString(Value: string): string;
end;
{$METHODINFO OFF}
TfmMain = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
DSServer1: TDSServer;
DSTCPServerTransport1: TDSTCPServerTransport;
DSServerClass1: TDSServerClass;
procedure DSServerClass1GetClass(DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
end;
var
fmMain: TfmMain;
implementation
{$R *.dfm}
uses System.StrUtils;
function TServerMethods.EchoString(Value: string): string;
begin
Result := Value;
end;
procedure TfmMain.DSServerClass1GetClass(DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
begin
PersistentClass := TServerMethods;
end;
procedure TfmMain.FormCreate(Sender: TObject);
begin
DSServer1 := TDSServer.Create(nil);
DSServer1.Name := 'DSServer1';
DSServer1.AutoStart := False;
DSTCPServerTransport1 := TDSTCPServerTransport.Create(nil);
DSTCPServerTransport1.Server := DSServer1;
DSServerClass1 := TDSServerClass.Create(nil);
DSServerClass1.Server := DSServer1;
DSServerClass1.OnGetClass := DSServerClass1GetClass;
DSServer1.Start;
end;
procedure TfmMain.FormDestroy(Sender: TObject);
begin
DSServer1.Stop;
DSServerClass1.Free;
DSTCPServerTransport1.Free;
DSServer1.Free;
end;
end.
I guess it is a known bug for XE8 by now, I think it's pretty serious, at least serious enough for us NOT to use XE8 before Embarcadero has given us an answer on what's going on.
We had a similar issue in XE2, as far as I remember it was on heavy callbacks.
This Eurekalog doesn't tell me much, it looks like deep inside datasnap, sorry I don't know how to make the log more readable.
EDIT:
I reported this issue to Embarcadero and got this response today:
//
Hi Henrik,
Part of the memory leaks are due to a bug in the System.Collections.Generics.pas, we are looking at releasing a fix this issue in very near future.
brgds
Roy.
//
Thought you might wanna know :)

Simple OpenGL Code not working

Just learning some OpenGL with delphi and trying something simple but not getting a result, I belive i should get a dark green form. But when i run this i get nothing. No errors either. maybe missing something?
unit First1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls,OpenGL, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm2 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
GLContext : HGLRC;
ErrorCode: GLenum;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
procedure TForm2.FormCreate(Sender: TObject);
var
pfd: TPixelFormatDescriptor;
FormatIndex: integer;
begin
fillchar(pfd,SizeOf(pfd),0);
with pfd do
begin
nSize := SizeOf(pfd);
nVersion := 1; {The current version of the desccriptor is 1}
dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;
iPixelType := PFD_TYPE_RGBA;
cColorBits := 24; {support 24-bit color}
cDepthBits := 32; {depth of z-axis}
iLayerType := PFD_MAIN_PLANE;
end; {with}
FormatIndex := ChoosePixelFormat(Canvas.Handle,#pfd);
SetPixelFormat(Canvas.Handle,FormatIndex,#pfd);
GLContext := wglCreateContext(Canvas.Handle);
wglMakeCurrent(Canvas.Handle,GLContext);
end; {FormCreate}
procedure TForm2.FormDestroy(Sender: TObject);
begin
wglMakeCurrent(Canvas.Handle,0);
wglDeleteContext(GLContext);
end;
procedure TForm2.FormPaint(Sender: TObject);
begin
{background}
glClearColor(0.0,0.4,0.0,0.0);
glClear(GL_COLOR_BUFFER_BIT);
{error checking}
errorCode := glGetError;
if errorCode<>GL_NO_ERROR then
raise Exception.Create('Error in Paint'#13+
gluErrorString(errorCode));
end;
end.
Since you request a single buffered context, you must call glFinish at the end of the rendering code, to commit your drawing commands to the implementation. However I strongly suggest you switch to using a double buffered context and instead of glFinish-ing you issue a wglSwapBuffers which implies a finish.

Resources