How to use a TcxCustomDataSource in a TcxExtLookupComboBox? - delphi

I use a TcxExtLookupComboBox from Devexpress and try to implement a custom datasource. I have set the customdatasource like this:
procedure TMainForm.FormCreate(Sender: TObject);
begin
fDataSource := TMyDataSource.Create;
cbotestSearch.Properties.View.DataController.CustomDataSource := fDataSource;
end;
TMyDataSource is defined here:
unit Datasource;
interface
uses
Classes,
IBQuery,
SysUtils,
cxCustomData;
type
TSearchItem = class
private
BoldID: String;
Display: String
end;
TMyDataSource = class(TcxCustomDataSource)
private
fSearchList: TList;
protected
function GetRecordCount: Integer; override;
function GetValue(ARecordHandle: TcxDataRecordHandle; AItemHandle: TcxDataItemHandle): Variant; override;
public
constructor Create;
destructor Destroy; override;
procedure GetData;
end;
implementation
constructor TMyDataSource.Create;
begin
inherited Create;
fSearchList := TList.Create;
end;
destructor TMyDataSource.Destroy;
begin
FreeAndNil(fSearchList);
inherited;
end;
procedure TMyDataSource.GetData;
var
vItem: TSearchItem;
begin
fSearchList.Clear;
vItem := TSearchItem.Create;
vItem.BoldID := '1000';
vItem.Display := 'test';
fSearchList.Add(vItem);
vItem := TSearchItem.Create;
vItem.BoldID := '1100';
vItem.Display := 'test2';
fSearchList.Add(vItem);
DataChanged; // Don't do anything as provider is nil
end;
function TMyDataSource.GetRecordCount: Integer;
begin
// Is never entered
Result := fSearchList.Count;
end;
function TMyDataSource.GetValue(ARecordHandle: TcxDataRecordHandle;
AItemHandle: TcxDataItemHandle): Variant;
begin
// Is never entered
Result := 'Test';
end;
end.
The problem is that TMyDataSource.GetValue is never called. Any hint how to fix ?
Update 1: I have another hint here. If I single step in the DataChanged method that should cause GetValue to be called is looks like this:
procedure TcxCustomDataSource.DataChanged;
begin
if Provider = nil then Exit;
// Code using Provider
end;
and Provider is nil in this case. But I have assigned the Datasource in Forms oncreate as you see.

cxExtLookupComboBox can only work with DB~views. Such views cannot accept instances of the TcxCustomDataSource object as a DataSource. So, your code will not work :-(. There is a suggestion to implement this feature in the future and it is registered at:
http://www.devexpress.com/Support/Center/ViewIssue.aspx?issueid=AS10025

Related

Named subcomponent inside compound(?) component

What I'm basically trying to create is a component that inherits from TScrollBox. That component has a TGroupBox and inside it a TFlowPanel. What I need is when I double click this component, a TCollection-like editor appears where I can add components (TFiltros) that will be children of that TFlowPanel. The problem is that I want those components to be named, such that I can directly access them via code, kinda like a TClientDataSet, where you add fields and they appear in your code.
I've managed to make it almost work by overriding GetChildren and making it return the children of the TFlowPanel. That also required me to make TFiltros's owner be the Form which they are in. It shows in the Structure panel as children (even tho they are not direct children) and also saves it in the DFM, but when I close the form and open it again, it fails to load the data back from the DFM, throwing an Access Violation. I have no idea how to override the loading to properly set the children.
Any help in how I can fix that, or even different ideas would be really nice. I'm new to creating Delphi components.
My current code which is heavily inspired in this question:
unit uFiltros;
interface
uses
System.SysUtils, System.Classes, Vcl.Controls, Vcl.ExtCtrls, Forms, StdCtrls,
ClRelatorio, Math, DesignEditors, DesignIntf, System.Generics.Collections;
type
TFiltrosEditor = class(TComponentEditor)
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): String; override;
function GetVerbCount: Integer; override;
end;
TFiltros = class(TScrollingWinControl)
private
FChilds: TList<TComponent>;
FGroupBox: TGroupBox;
FFlowPanel: TFlowPanel;
FWidth: Integer;
procedure OnFlowPanelResize(Sender: TObject);
procedure SetWidth(AWidth: Integer);
public
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
function GetChildOwner: TComponent; override;
constructor Create(AOwner: TComponent); override;
property Childs: TList<TComponent> read FChilds;
published
property Width: Integer read FWidth write SetWidth;
end;
TClFiltro = class(TFiltro)
private
FFiltros: TFiltros;
protected
procedure SetParent(AParent: TWinControl); override;
public
constructor Create(AOwner: TComponent; AFiltros: TFiltros); reintroduce;
function GetParentComponent: TComponent; override;
function HasParent: Boolean; override;
property Parent: TWinControl write SetParent;
end;
TFiltroItem = class(TCollectionItem)
private
FFiltro: TClFiltro;
protected
function GetDisplayName: String; override;
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
published
property Filtro: TClFiltro read FFiltro write FFiltro;
end;
TFiltrosCollection = class(TOwnedCollection)
private
FDesigner: IDesigner;
public
property Designer: IDesigner read FDesigner write FDesigner;
end;
procedure Register;
implementation
uses Dialogs, ClFuncoesBase, Vcl.Graphics, ColnEdit;
procedure Register;
begin
RegisterClass(TClFiltro);
RegisterNoIcon([TClFiltro]);
RegisterComponents('Cl', [TFiltros]);
RegisterComponentEditor(TFiltros, TFiltrosEditor);
end;
{ TFiltroItem }
constructor TFiltroItem.Create(Collection: TCollection);
begin
inherited;
if Assigned(Collection) then
begin
FFiltro := TClFiltro.Create(TFiltros(Collection.Owner).Owner, TFiltros(Collection.Owner));
FFiltro.Name := TFiltrosCollection(Collection).Designer.UniqueName(TClFiltro.ClassName);
FFiltro.Parent := TFiltros(Collection.Owner).FFlowPanel;
FFiltro.Margins.Top := 1;
FFiltro.Margins.Bottom := 1;
FFiltro.AlignWithMargins := True;
//FFiltro.SetSubComponent(True);
end;
end;
destructor TFiltroItem.Destroy;
begin
FFiltro.Free;
inherited;
end;
function TFiltroItem.GetDisplayName: String;
begin
Result := FFiltro.Name;
end;
{ TFiltros }
constructor TFiltros.Create(AOwner: TComponent);
begin
inherited;
FChilds := TList<TComponent>.Create;
// Configurações ScrollBox
Align := TAlign.alRight;
AutoScroll := False;
AutoSize := True;
//Configurações GroupBox
FGroupBox := TGroupBox.Create(Self);
FGroupBox.Parent := Self;
FGroupBox.Caption := ' Fil&tros ';
FGroupBox.Font.Style := [fsBold];
//Configurações FlowPanel
FFlowPanel := TFlowPanel.Create(FGroupBox);
FFlowPanel.Parent := FGroupBox;
FFlowPanel.Top := 15;
FFlowPanel.Left := 2;
FFlowPanel.AutoSize := True;
FFlowPanel.FlowStyle := TFlowStyle.fsRightLeftTopBottom;
FFlowPanel.Caption := '';
FFlowPanel.OnResize := OnFlowPanelResize;
FFlowPanel.BevelOuter := TBevelCut.bvNone;
end;
function TFiltros.GetChildOwner: TComponent;
begin
Result := FFlowPanel;
end;
procedure TFiltros.GetChildren(Proc: TGetChildProc; Root: TComponent);
var I: Integer;
begin
// inherited;
for I := 0 to FChilds.Count - 1 do
Proc(TComponent(FChilds[I]));
end;
procedure TFiltros.OnFlowPanelResize(Sender: TObject);
begin
FGroupBox.Width := FFlowPanel.Width + 4;
FGroupBox.Height := Max(FFlowPanel.Height + 17, Height);
VertScrollBar.Range := FGroupBox.Height;
FWidth := FFlowPanel.Width;
end;
procedure TFiltros.SetWidth(AWidth: Integer);
begin
FFlowPanel.Width := AWidth;
FWidth := FFlowPanel.Width;
OnFlowPanelResize(Self);
end;
{ TFiltrosEditor }
procedure TFiltrosEditor.ExecuteVerb(Index: Integer);
var LCollection: TFiltrosCollection;
I: Integer;
begin
LCollection := TFiltrosCollection.Create(Component, TFiltroItem);
LCollection.Designer := Designer;
for I := 0 to TFiltros(Component).Childs.Count - 1 do
with TFiltroItem.Create(nil) do
begin
FFiltro := TClFiltro(TFiltros(Component).Childs[I]);
Collection := LCollection;
end;
ShowCollectionEditorClass(Designer, TCollectionEditor, Component, LCollection, 'Filtros');
end;
function TFiltrosEditor.GetVerb(Index: Integer): String;
begin
Result := 'Editar filtros...';
end;
function TFiltrosEditor.GetVerbCount: Integer;
begin
Result := 1;
end;
{ TClFiltro }
constructor TClFiltro.Create(AOwner: TComponent; AFiltros: TFiltros);
begin
inherited Create(AOwner);
FFiltros := AFiltros;
end;
function TClFiltro.GetParentComponent: TComponent;
begin
Result := FFiltros;
end;
function TClFiltro.HasParent: Boolean;
begin
Result := Assigned(FFiltros);
end;
procedure TClFiltro.SetParent(AParent: TWinControl);
begin
if Assigned(AParent) then
FFiltros.FChilds.Add(Self)
else
FFiltros.FChilds.Remove(Self);
inherited;
end;
end.
I've finally managed to do it. It required a combination of TOwnedCollection and overriding GetChildren and GetParentComponent.
Basically what I've learned (and you can correct me if I'm wrong), is the following:
For a component to be shown in the Structure tab at all, the Owner of that component has to be the form. So the first thing was to create TFiltro with that owner.
GetParentComponent defines where in the Structure tree the component is going to reside in, it doesn't necessarily have to be the actual parent. So the second thing was to make GetParentComponent of the TFiltro return the TScrollBox but set the actual parent to be the TFlowPanel.
Now, as the parent of TFiltro no longer is the form, it won't save it to the DFM, because TFlowPanel is the actual parent but is not defined as a subcomponent. Overriding GetChildren in the TScrollBox and making it return every TFiltro solves this, and it is now saved in the DFM as a child.
But now, for the TFiltro to be properly read back from the DFM and be set again accordingly, it has to be a published value in an item inside the TOwnedCollection, which itself is a published value in the TScrollBox. Then, make the TCollectionItem published value's set function define the parent of the TFiltro to be the TFlowPanel.
The article which helped me the most in achieving this is available in the WayBack machine.

Where can I find TMonitor (Delphi 7) or how can I replace it with an alternative function?

I have a code (Singleton- Pattern) which works with Delphi RAD 10.1
type
TSharedData = class
private
FPOL: integer;
class var FUniqueInstance: TSharedData;
procedure SetFPol(const Value: integer);
constructor Create;
public
class function GetInstance: TSharedData;
property POL: integer read FPOL write SetFPol;
end;
var
Key: TObject;
implementation
{ TSharedData }
constructor TSharedData.Create;
begin
SetFPol(1);
end;
class function TSharedData.GetInstance: TSharedData;
begin
TMonitor.Enter(Key); // <-- error here
try
if FUniqueInstance = nil then
begin
FUniqueInstance := TSharedData.Create;
end;
finally
TMonitor.Exit(Key);
end;
Result := FUniqueInstance;
end;
procedure TSharedData.SetFPol(const Value: integer);
begin
FPOL := Value;
end;
initialization
Key:= TObject.Create;
finalization
Key.Free;
I need now the same code in Delphi 7. But the compiler said, "TMonitor isn't known".
Where can I find TMonitor or how can I replace it with an alternative function?
I thank you in advance for any information.
You can use TCriticalSection from SyncObjs unit.
The approach changes just a little bit. The critical section should be used as an object. So if you want to protect an area of you object on can do something like:
type
TSafeCounter = class(TObject)
private
FValue: Integer;
FCriticalSection: TCriticalSection;
public
constructor Create;
destructor Destroy; override;
procedure SafeInc;
procedure SafeDec;
function CurValue: Integer;
end;
implementation
{ TSafeCounter }
constructor TSafeCounter.Create;
begin
FCriticalSection := TCriticalSection.Create;
end;
function TSafeCounter.CurValue: Integer;
begin
FCriticalSection.Acquire;
try
Result := FValue;
finally
FCriticalSection.Release;
end;
end;
procedure TSafeCounter.SafeDec;
begin
FCriticalSection.Acquire;
try
Dec(FValue);
finally
FCriticalSection.Release;
end;
end;
destructor TSafeCounter.Destroy;
begin
FCriticalSection.Free;
inherited;
end;
procedure TSafeCounter.SafeInc;
begin
FCriticalSection.Acquire;
try
Inc(FValue);
finally
FCriticalSection.Release;
end;
end;
If you are facing very extreme scenario (performance), you can work another kinds of implementations of critical sections, but them will also increase the complexity of working with it like the read/write critical section.

Mocking interfaces in DUnit with Delphi-Mocks and Spring4D

So, I am getting Access Violation error when try to Mock 2-nd composite interface, below examples of code with using Delphi-Mocks and Spring4D frameworks
unit u_DB;
type
TDBObject = class
public
property ID: TGUID;
end;
TDBCRM = class(TDBObject)
public
property SOME_FIELD: TSomeType;
end;
unit i_dmServer;
type
{$M+}
IdmServer = interface
['{A4475441-9651-4956-8310-16FB710EAE5E}']
function GetServiceConnection: TServiceConnection;
function GetCurrentUser(): TUser;
end;
unit d_ServerWrapper;
type
TdmServerWrapper = class(TInterfacedObject, IdmServer)
private
function GetServiceConnection: TServiceConnection;
function GetCurrentUser(): TUser;
protected
FdmServer: TdmServer;
end;
implementation
constructor TdmServerWrapper.Create();
begin
inherited Create();
FdmServer := TdmServer.Create(nil);
end;
end.
unit i_BaseDAL;
type
{$M+}
IBaseDAL<T: TDBObject, constructor> = interface
['{56D48844-BD7F-4FF8-A4AE-30DA1A82AD67}']
procedure RefreshData(); ....
end;
unit u_BaseDAL;
type
TBaseDAL<T: TDBObject, constructor> = class(TInterfacedObject, IBaseDAL<TDBObject>)
protected
FdmServer: IdmServer;
public
procedure RefreshData();
end;
implementation
procedure TBaseDAL<T>.Create;
begin
FdmServer := GlobalContainer.Resolve<IdmServer>;
end;
end.
unit ChildFrame;
interface
type
TChildFrame = class(TFrame)
private
fDM: IBaseDAL<TDBObject>;
function GetDM: IBaseDAL<TDBObject>;
procedure SetDM(const Value: IBaseDAL<TDBObject>);
public
constructor Create(AOwner: TComponent); override;
property DM: IBaseDAL<TDBObject> read GetDM write SetDM;
end;
implementation
constructor TChildFrame.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
DM := nil;
end;
function TChildFrame.GetDM: IBaseDAL<TDBObject>;
begin
if not Assigned(fDM) then
fDM := GlobalContainer.Resolve<IBaseDAL<TDBObject>>;
Result := fDM;
end;
procedure TfrmCustomChildFrame.SetDM(const Value: IBaseDAL<TDBObject>);
begin
if Assigned(fDM) then
fDM := nil;
fDM := Value;
end;
end.
TCRMFrame = class(TChildFrame)
....
end;
procedure TCRMFrame.Create
begin
DM := GlobalContainer.Resolve('i_BaseDAL.IBaseDAL<u_DB.TDBObject>#TBaseDAL<u_DB.TDBCRM>').AsInterface as IBaseDAL<TDBObject>;
// DM := GlobalContainer.Resolve(IBaseDAL<TomDBObject>); {Not compiled et all: "E2250 There is no overloaded version of 'Resolve' that can be called with these arguments"}
end;
REGISTERING TYPES
unit RegisteringTypes.pas
procedure RegTypes;
implementation
procedure RegTypes;
begin
GlobalContainer.RegisterType<TdmServerWrapper>;
GlobalContainer.RegisterType<TBaseDAL<TDBObject>, IBaseDAL<TDBObject>>;
GlobalContainer.RegisterType<TBaseDAL<TDBCRM>, IBaseDAL<TDBCRM>>;
GlobalContainer.Build;
end;
initialization
RegTypes
end.
DUNIT TEST
type
TestTCRM = class(TTestCase)
private
FFrame: TCRMFrame;
FBaseDALMock: TMock<TBaseDAL<TDBObject>>;
procedure Init;
protected
procedure SetUp; override;
published
end;
implementation
procedure TestTCRM.Init;
begin
inherited;
GlobalContainer.RegisterType<IdmServer>.DelegateTo(
function: IdmServer
begin
Result := TMock<IdmServer>.Create;
end
);
GlobalContainer.RegisterType<IBaseDAL<TDBCRM>>.DelegateTo(
function: IBaseDAL<TDBCRM>
begin
Result := TMock<IBaseDAL<TDBCRM>>.Create;
end
);
GlobalContainer.RegisterType<IBaseDAL<TDBObject>>.DelegateTo(
function: IBaseDAL<TDBObject>
begin
Result := TMock<IBaseDAL<TDBObject>>.Create;
end
);
GlobalContainer.Build;
end;
procedure TestTfrCRMAccountClasses.SetUp;
begin
inherited;
Init;
FFrame := TCRMFrame.Create(nil); // and I got ACCESS VIOLATION HERE
end;
Full sources of test project here - https://drive.google.com/file/d/0B6KvjsGVp4ONeXBNenlMc2J0R2M.
Colleagues, please advise me where I am wrong. Thank you in advance!
The AV is raised from Delphi.Mocks.
Here is a minimal test case to reproduce it:
procedure DelphiMocksTest;
var
func: TFunc<IdmServer>;
dm: IdmServer;
i: IInitializable;
begin
func :=
function: IdmServer
begin
Result := TMock<IdmServer>.Create;
Supports(dm, IInitializable, i); // works
end; // TMock record goes out of scope and something happens
dm := func();
Supports(dm, IInitializable, i); // fails
end;
You need to have a reference to the TMock somewhere, because the mocks are records which will get cleaned up when they go out of scope.
This should work :
procedure DelphiMocksTest;
var
func: TFunc<IdmServer>;
dm: IdmServer;
i: IInitializable;
mock : TMock<IdmServer>;
begin
func := function: IdmServer
begin
mock := TMock<IdmServer>.Create;
Supports(dm, IInitializable, i); // works
result := mock;
end;
dm := func();
Supports(dm, IInitializable, i); // fails
end;

Keep values from the beforepost event to the afterpost event

I am writing this question for Delphi 2007, but I'm pretty sure that this is a common problem in all kind of languages.
So, I have a project where I need to keep informations about the old and new value of certain fields (which are given in the BeforePost event of the dataset I'm working with) and use them in the AfterPost event.
For now, I have been using global variables, but there is already so many of them in the project that this is becoming a real issue when it comes to managing documentation and/or comments.
Basically, I am asking if there is a better way (in Delphi 2007 or in general) to keep the informations from the BeforePost event of a Dataset and get them back in the AfterPost event.
first create a new Custom Data Source
TDataRecord = array of record
FieldName: string;
FieldValue: Variant;
end;
TMyDataSource = class(TDataSource)
private
LastValues: TDataRecord;
procedure MyDataSourceBeforePost(DataSet: TDataSet);
procedure SetDataSet(const Value: TDataSet);
function GetDataSet: TDataSet;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function GetLastValue(FieldName: string): Variant;
property MyDataSet: TDataSet read GetDataSet write SetDataSet;
end;
{ TMyDataSource }
constructor TMyDataSource.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
destructor TMyDataSource.Destroy;
begin
SetLength(LastValues, 0);
inherited Destroy;
end;
function TMyDataSource.GetDataSet: TDataSet;
begin
Result := DataSet;
end;
procedure TMyDataSource.SetDataSet(const Value: TDataSet);
begin
DataSet := Value;
DataSet.BeforePost := MyDataSourceBeforePost;
end;
procedure TMyDataSource.MyDataSourceBeforePost(DataSet: TDataSet);
var
i: integer;
begin
SetLength(LastValues, DataSet.FieldCount);
for i:=0 to DataSet.FieldCount-1 do
begin
LastValues[i].FieldName := DataSet.Fields.Fields[i].FieldName;
LastValues[i].FieldValue := DataSet.Fields.Fields[i].OldValue;
end;
end;
function TMyDataSource.GetLastValue(FieldName: string): Variant;
var
i: integer;
begin
Result := Null;
for i:=0 to Length(LastValues)-1 do
if SameText(FieldName, LastValues[i].FieldName) then
begin
Result := LastValues[i].FieldValue;
break;
end;
end;
and after override application Data Source
TForm1 = class(TForm)
private
MyDataSource: TMyDataSource;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ADOQuery1.Active := true;
MyDataSource := TMyDataSource.Create(Self);
MyDataSource.MyDataSet := ADOQuery1;
DBGrid1.DataSource := MyDataSource;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MyDataSource.Free;
end;
procedure TForm1.ADOQuery1AfterPost(DataSet: TDataSet);
var
AValue: Variant;
begin
AValue := MyDataSource.GetLastValue('cname');
if not VarIsNull(AValue) then;
end;

Creating replacement TApplication for experimentation?

I got the crazy idea one day to make a completely new replacement of TApplication for experimentation. I got everything to compile and run, and it does show the main form properly, everything responds good, but upon closing the form, the application does not halt. I'm sure I copied all the necessary stuff from the original Forms.pas TApplication (registering close event) but I don't see it working. I have to terminate the debug session the nasty way.
My goal in this little experiment is to build a lightweight application for very simple things instead of all the possible things a TApplication can handle, and also mostly so I have some good experience in such a field.
Here's the unit as I have it now, and below is the implementation of it.
unit JDForms;
interface
uses
Forms, Classes, SysUtils, StrUtils, Windows, Win7, XPMan, Variants,
Messages, Dialogs;
type
TJDForm = class;
TJDApplication = class;
TJDApplicationThread = class;
TJDForm = class(TCustomForm)
private
public
published
end;
TJDApplication = class(TComponent)
private
fRunning: Bool;
fTerminated: Bool;
fThread: TJDApplicationThread;
fMainForm: TJDForm;
fOnMessage: TMessageEvent;
fShowMainForm: Bool;
fHandle: HWND;
procedure ThreadTerminated(Sender: TObject);
procedure HandleMessage;
procedure ProcessMessages;
function ProcessMessage(var Msg: TMsg): Boolean;
procedure ThreadSync(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
property Thread: TJDApplicationThread read fThread;
procedure Initialize;
procedure Run;
procedure CreateForm(InstanceClass: TComponentClass; var Reference);
procedure Terminate;
property Terminated: Bool read fTerminated;
procedure HandleException(Sender: TObject);
property Handle: HWND read fHandle;
published
property ShowMainForm: Bool read fShowMainForm write fShowMainForm;
property OnMessage: TMessageEvent read fOnMessage write fOnMessage;
end;
TJDApplicationThread = class(TThread)
private
fOwner: TJDApplication;
fStop: Bool;
fOnSync: TNotifyEvent;
procedure DoSync;
protected
procedure Execute; override;
public
constructor Create(AOwner: TJDApplication);
destructor Destroy; override;
procedure Start;
procedure Stop;
published
property OnSync: TNotifyEvent read fOnSync write fOnSync;
end;
var
JDApplication: TJDApplication;
implementation
procedure DoneApplication;
begin
with JDApplication do begin
if Handle <> 0 then ShowOwnedPopups(Handle, False);
//ShowHint := False;
Destroying;
DestroyComponents;
end;
end;
{ TJDApplication }
constructor TJDApplication.Create(AOwner: TComponent);
begin
fRunning:= False;
fTerminated:= False;
fMainForm:= nil;
fThread:= TJDApplicationThread.Create(Self);
fThread.FreeOnTerminate:= True;
fThread.OnTerminate:= ThreadTerminated;
fShowMainForm:= True;
end;
procedure TJDApplication.CreateForm(InstanceClass: TComponentClass; var Reference);
var
Instance: TComponent;
begin
Instance:= TComponent(InstanceClass.NewInstance);
TComponent(Reference) := Instance;
try
Instance.Create(Self);
except
TComponent(Reference):= nil;
raise;
end;
if (fMainForm = nil) and (Instance is TForm) then begin
TForm(Instance).HandleNeeded;
fMainForm:= TJDForm(Instance);
end;
end;
procedure TJDApplication.HandleException(Sender: TObject);
begin
{
if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
if ExceptObject is Exception then
begin
if not (ExceptObject is EAbort) then
if Assigned(FOnException) then
FOnException(Sender, Exception(ExceptObject))
else
ShowException(Exception(ExceptObject));
end else
SysUtils.ShowException(ExceptObject, ExceptAddr);
}
end;
procedure TJDApplication.HandleMessage;
var
Msg: TMsg;
begin
if not ProcessMessage(Msg) then begin
//Idle(Msg);
end;
end;
function TJDApplication.ProcessMessage(var Msg: TMsg): Boolean;
var
Handled: Boolean;
begin
Result := False;
if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
begin
Result := True;
if Msg.Message <> WM_QUIT then begin
Handled := False;
if Assigned(FOnMessage) then FOnMessage(Msg, Handled);
//if not IsHintMsg(Msg) and not Handled and not IsMDIMsg(Msg) and
//not IsKeyMsg(Msg) and not IsDlgMsg(Msg) then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end else begin
fTerminated:= True;
end;
end;
end;
procedure TJDApplication.ProcessMessages;
var
Msg: TMsg;
begin
while ProcessMessage(Msg) do {loop};
end;
procedure TJDApplication.Initialize;
begin
if InitProc <> nil then TProcedure(InitProc);
end;
procedure TJDApplication.Run;
begin {
fRunning := True;
try
AddExitProc(DoneApplication);
if FMainForm <> nil then
begin
case CmdShow of
SW_SHOWMINNOACTIVE: FMainForm.FWindowState := wsMinimized;
SW_SHOWMAXIMIZED: MainForm.WindowState := wsMaximized;
end;
if FShowMainForm then
if FMainForm.FWindowState = wsMinimized then
Minimize else
FMainForm.Visible := True;
repeat
try
HandleMessage;
except
HandleException(Self);
end;
until Terminated;
end;
finally
FRunning := False;
end;
}
fRunning:= True;
try
AddExitProc(DoneApplication);
if fMainForm <> nil then begin
fHandle:= fMainForm.Handle;
if fShowMainForm then begin
fMainForm.Show;
end;
fThread.Start;
repeat
try
HandleMessage;
//--- THREAD HANDLING MESSAGES ---
except
HandleException(Self);
end;
until fTerminated;
end else begin
//Main form is nil - can not run
end;
finally
fRunning:= False;
fTerminated:= True;
end;
end;
procedure TJDApplication.Terminate;
begin
fTerminated:= True;
try
fThread.Stop;
except
end;
if CallTerminateProcs then PostQuitMessage(0);
end;
procedure TJDApplication.ThreadTerminated(Sender: TObject);
begin
//Free objects
end;
procedure TJDApplication.ThreadSync(Sender: TObject);
var
Msg: TMsg;
begin
if not ProcessMessage(Msg) then begin
//Idle(Msg);
end;
end;
{ TJDApplicationThread }
constructor TJDApplicationThread.Create(AOwner: TJDApplication);
begin
inherited Create(True);
fOwner:= AOwner;
end;
destructor TJDApplicationThread.Destroy;
begin
inherited;
end;
procedure TJDApplicationThread.DoSync;
begin
Self.fOwner.ThreadSync(Self);
// if assigned(fOnSync) then fOnSync(Self);
end;
procedure TJDApplicationThread.Execute;
var
ST: Integer;
begin
ST:= 5;
fStop:= False;
while (not Terminated) and (not fStop) do begin
//----- BEGIN -----
Synchronize(DoSync);
//----- END -----
//Sleep(1000 * ST);
end;
end;
procedure TJDApplicationThread.Start;
begin
fStop:= False;
Resume;
end;
procedure TJDApplicationThread.Stop;
begin
fStop:= True;
Suspend;
end;
initialization
JDApplication:= TJDApplication.Create(nil);
finalization
if assigned(JDApplication) then begin
JDApplication.Free;
JDApplication:= nil;
end;
end.
And here's an application using this:
program Win7FormTestD7;
uses
Forms,
W7Form1 in 'W7Form1.pas' {Win7Form1},
JDForms in 'JDForms.pas';
begin
JDApplication.Initialize;
JDApplication.CreateForm(TWin7Form1, Win7Form1);
JDApplication.Run;
end.
The form 'W7Form1' is just a plain form with a couple random controls on it to test with.
Users here should not ask the question of why I want to do this, I have my reasons. I learn by doing, not by someone showing me or by reading some book or finding a bunch of code which I don't know how it works. This is a way for me to better learn the workings of applications and be able to expand my knowledge in the field to be able to build more complex applications in the future.
Keep in mind that TCustomForm has no concept of your TJDApplication class, it only works with the Forms.TApplication class instead. Make sure your TJDApplication.Run() method is exiting when the Forms.TApplication.Terminated property has been set to True.
If building lightweight application is your motto, I suggest you to play around with :
The KOL Library
The SDA Framework
VCL Light by Paul TOTH
LVCL based on VCL Light code by SO member Arnaud Bouchez.

Resources