Delphi Component Creation.. Getting Beyond First Base - delphi

I've used VBto as a starting point plus a lot of study of Delphi 6 User's Guide. I can make my new component compile, but I can't figure a way to get it to display so I can finish debugging it. And 50 years of programming experience isn't helping. Here are the guts of my component:
type
TChangeEvent = procedure(Sender: TObject; v: String) of object;
TTxtSpnr = class(TWinControl)
Lbl: TLabel;
Txt: TEdit;
Scrll: TScrollBar;
private
FonChange: TChangeEvent;
busy, tweaked: Boolean;
NewValue: String;
protected
procedure Changed(v: String); dynamic;
property onChange: TChangeEvent read FonChange write FOnChange;
procedure ScrllChange(Sender: TObject);
procedure ScrllScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
procedure TxtEnter(Sender: TObject);
procedure TxtKeyUp(Sender: TObject; var Key: WORD; Shift: TShiftState);
procedure TxtExit(Sender: TObject);
procedure Txt_Validate(var Cancel: Boolean);
public
function GetCaption(): String;
procedure SetCaption(New_Caption: String);
function GetMax(): Smallint;
procedure SetMax(New_Max: Smallint);
function MaxOf(a: Double; B: Longint): OleVariant;
function MinOf(a: OleVariant; B: Longint): OleVariant;
function GetMin(): Smallint;
procedure SetMin(New_Min: Smallint);
function GetText(): String;
procedure SetText(New_Text: String);
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Caption: String read GetCaption write SetCaption;
property Enabled: Boolean read GetEnabled write SetEnabled;
property Max: Smallint read GetMax write SetMax;
property Min: Smallint read GetMin write SetMin;
property Text: String read GetText write SetText;
end;
var
TxtSpnr: TTxtSpnr;
implementation
uses Math;
{$R *.dfm}
procedure TTxtSpnr.Changed(V: String); begin
if assigned(FonChange) then FonChange(self,V);
end;
constructor TTxtSpnr.Create(AOwner: TComponent); begin
inherited Create(AOwner);
Lbl := TLabel.Create(Self);
with Lbl do begin
Parent := Self;
end;
Txt := TEdit.Create(Self);
with Txt do begin
Parent := Self;
end;
Scrll := TScrollBar(Self);
with Scrll do begin
Parent := Self;
end;
end;
and here's the test driver:
type
TForm1 = class(TForm)
FTxtSpnr: TTxtSpnr;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject); begin
FTxtSpnr := TTxtSpnr.create(Self);
with FTxtSpnr do begin
Left:=10;
Top:=10;
Visible:=true;
Show;
end;
end;
But it doesn't compile and says, in the constructor, "An object can't be its own parent". Take out the Parent settings, it compiles but doesn't display the components. What am I missing?

First,
Scrll := TScrollBar(Self);
should of course read
Scrll := TScrollBar.Create(Self);
Second,
FTxtSpnr := TTxtSpnr.create(Self);
with FTxtSpnr do begin
Left:=10;
Top:=10;
Visible:=true;
Show;
end;
should be
FTxtSpnr := TTxtSpnr.create(Self);
with FTxtSpnr do
begin
Parent := Self;
Left := 10;
Top := 10;
end;
You forgot to set the parent.
Also, the global variable
var
TxtSpnr: TTxtSpnr;
looks dangerous. If you don't know exactly why you added those two lines, you should probably remove them.

Related

Lazarus: TListBox.Style:= lbVirtual but no OnData event

From Delphi 6 on it was possible to put millions of lines in the TListBox component via .Style:= lbVirtual and using the OnData event. In Lazarus lbVirtual exists, too, but not the OnData event. I want to extend this component to be able to display millions of lines, but I get errors during compilation.
My problem is that I can't really port code from Delphi to Lazarus when it comes to using lbVirtual in Lazarus, as no OnData event exists.
Delphi 7:
ListBox.Style:= lbVirtual;
property OnData;
ListBox.Count:= // for reading
Lazarus:
ListBox.Style:= lbVirtual; // which behaves like lbStandard
ListBox.Count:= // ReadOnly
In Lazarus I used the property OnData in my new L_Listbox component and ListBox.Count:=. I still don't know if L_ListBox lines will show up like I know it from lbVirtual. Now I get compiler error messages such as
resourcestring
LongInt
I thought I would solve this by appending to uses Math. However, it did not help. All compilation errors pop up in the file: l_listbox.pas
LLB.pas
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit LLB;
{$warn 5023 off : no warning about unused units}
interface
uses
L_ListBox, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('L_ListBox', #L_ListBox.Register);
end;
initialization
RegisterPackage('LLB', #Register);
end.
LLB.lpk
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="LLB"/>
<Type Value="RunAndDesignTime"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\"/>
</SearchPaths>
</CompilerOptions>
<Files Count="1">
<Item1>
<Filename Value="l_listbox.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="L_ListBox"/>
</Item1>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
</Package>
</CONFIG>
l_listbox.pas (see comments where the compiler complains in function TListBoxStrings.GetObject(Index: Integer): TObject;)
unit L_ListBox;
{$mode objfpc}{$H+}
interface
uses Math, StdCtrls, Controls, Classes, Forms, Graphics, Messages, Windows, SysUtils, Commctrl, Types,
LResources, LCLType, LCLIntf, LMessages;
resourcestring
SErrorSettingCount = 'Error setting %s.Count';
SListBoxMustBeVirtual = 'Listbox (%s) style must be virtual in order to set Count';
SListIndexError = 'List %s is invalid';
type
TListBoxStyle = (lbStandard, lbOwnerDrawFixed, lbOwnerDrawVariable, lbVirtual, lbVirtualOwnerDraw);
TLBGetDataEvent = procedure(Control: TWinControl; Index: Integer; var Data: string) of object;
TLBFindDataEvent = function(Control : TWinControl; FindString: string): Integer of object;
TLBGetDataObjectEvent = procedure(Control: TWinControl; Index: Integer; var DataObject: TObject) of object;
TL_ListBox = class(Tlistbox)
private
FCount : Integer;
FStyle : TListBoxStyle;
FOnDataFind : TLBFindDataEvent;
FOnData : TLBGetDataEvent;
FOnDataObject : TLBGetDataObjectEvent;
function GetSelCount : Integer;
function GetCount : Integer;
procedure SetCount(const Value: Integer);
procedure SetStyle(Value: TListBoxStyle);
protected
function DoGetData(const Index: Integer): String;
function DoGetDataObject(const Index: Integer): TObject;
function DoFindData(const Data: String): Integer;
function InternalGetItemData(Index: Integer): Longint; dynamic;
procedure InternalSetItemData(Index: Integer; AData: Longint); dynamic;
function GetItemData(Index: Integer): LongInt; dynamic;
procedure SetItemData(Index: Integer; AData: LongInt); dynamic;
procedure CreateParams(var Params: TCreateParams); override;
public
property SelCount : Integer read GetSelCount;
property Count : Integer read GetCount write SetCount;
published
property OnData : TLBGetDataEvent read FOnData write FOnData;
property OnDataObject : TLBGetDataObjectEvent read FOnDataObject write FOnDataObject;
property OnDataFind : TLBFindDataEvent read FOnDataFind write FOnDataFind;
property Style: TListBoxStyle read FStyle write SetStyle default lbStandard;
end;
procedure Register;
implementation
uses RTLConsts;
procedure Register;
begin
RegisterComponents('ex',[TL_ListBox]);
end;
type
TListBoxStrings = class(TStrings)
private
ListBox: TL_ListBox;
protected
function GetCount: Integer; override;
function GetObject(Index: Integer): TObject; override;
procedure PutObject(Index: Integer; AObject: TObject); override;
public
end;
{ TL_ListBox }
procedure TL_ListBox.CreateParams(var Params: TCreateParams);
const
Styles: array[TListBoxStyle] of DWORD = (0, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWVARIABLE, LBS_OWNERDRAWFIXED, LBS_OWNERDRAWFIXED);
Data: array[Boolean] of DWORD = (LBS_HASSTRINGS, LBS_NODATA);
begin
inherited CreateParams(Params);
CreateSubClass(Params, 'ListBox');
with Params do begin
Style := Style or ({WS_HSCROLL or }WS_VSCROLL or Data[Self.Style in [lbVirtual]] or LBS_NOTIFY) or Styles[FStyle];
end;
end;
function TL_ListBox.DoFindData(const Data: String): Integer;
begin
if Assigned(FOnDataFind) then Result := FOnDataFind(Self, Data) else Result := -1;
end;
function TL_ListBox.DoGetData(const Index: Integer): String;
begin
if Assigned(FOnData) then FOnData(Self, Index, Result);
end;
function TL_ListBox.DoGetDataObject(const Index: Integer): TObject;
begin
if Assigned(FOnDataObject) then FOnDataObject(Self, Index, Result);
end;
function TL_ListBox.GetCount: Integer;
begin
if Style in [lbVirtual] then Result := FCount else Result := Items.Count;
end;
function TL_ListBox.GetItemData(Index: Integer): LongInt;
begin
Result := SendMessage(Handle, LB_GETITEMDATA, Index, 0);
end;
function TL_ListBox.GetSelCount: Integer;
begin
Result := SendMessage(Handle, LB_GETSELCOUNT, 0, 0);
end;
function TL_ListBox.InternalGetItemData(Index: Integer): Longint;
begin
Result := GetItemData(Index);
end;
procedure TL_ListBox.InternalSetItemData(Index, AData: Integer);
begin
SetItemData(Index, AData);
end;
procedure TL_ListBox.SetCount(const Value: Integer);
var
Error: Integer;
begin
if Style in [lbVirtual] then
begin
// Limited to 32767 on Win95/98 as per Win32 SDK
Error := SendMessage(Handle, LB_SETCOUNT, Value, 0);
if (Error <> LB_ERR) and (Error <> LB_ERRSPACE) then FCount := Value else raise Exception.CreateFmt(LoadStr(SErrorSettingCount), [Name]);
end
else raise Exception.CreateFmt(LoadStr(SListBoxMustBeVirtual), [Name]);
end;
procedure TL_ListBox.SetItemData(Index, AData: Integer);
begin
SendMessage(Handle, LB_SETITEMDATA, Index, AData);
end;
procedure TL_ListBox.SetStyle(Value: TListBoxStyle);
begin
if FStyle <> Value then
begin
if Value in [lbVirtual] then
begin
Items.Clear;
Sorted := False;
end;
FStyle := Value;
end;
end;
{ TListBoxStrings }
function TListBoxStrings.GetCount: Integer;
begin
Result := SendMessage(ListBox.Handle, LB_GETCOUNT, 0, 0);
end;
function TListBoxStrings.GetObject(Index: Integer): TObject;
begin
if ListBox.Style in [lbVirtual] then
Result := ListBox.DoGetDataObject(Index)
else
begin
Result := TObject(ListBox.GetItemData(Index)); // Compiler complains here on TObject...
if Longint(Result) = LB_ERR then Error(SListIndexError, Index); // ...and here on Longint
end;
end;
procedure TListBoxStrings.PutObject(Index: Integer; AObject: TObject);
begin
if (Index <> -1) and not (ListBox.Style in [lbVirtual]) then
ListBox.SetItemData(Index, LongInt(AObject));
end;
end.
My Form:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
L_ListBox;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
L_ListBox1: TL_ListBox;
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure L_ListBox1Data(Control: TWinControl; Index: Integer;
var Data: string);
private
public
end;
var
Form1: TForm1;
MyList : TStringlist;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
MyList := TStringlist.Create;
L_ListBox1.Style := lbVirtual;
MyList.LoadFromFile('ex.txt');
L_ListBox1.Count := MyList.Count;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MyList.Free;
end;
procedure TForm1.L_ListBox1Data(Control: TWinControl; Index: Integer;
var Data: string);
begin
Data := MyList[Index];
end;
end.
I corrected the code in L_ListBox.pas
procedure Register;
implementation
uses RTLConsts;
resourcestring
SErrorSettingCount = 'Error setting% s.Count';
SListBoxMustBeVirtual = 'Listbox (% s) style must be virtual in order to set Count';
SListIndexError = 'List% s is invalid';
procedure Register;
begin
RegisterComponents ('ex', [TL_ListBox]);
end;
I am getting an error:
[Debugger Exception Notification]
Project project1 raised exception class 'Exception' with message:
Error setting L_ListBox1.Count
What is the construction in Lazarus ?
since the compiler stops I marked bold
TObject
Longint
Result := TObject(ListBox.GetItemData(Index));
if Longint(Result) = LB_ERR then Error(SListIndexError, Index);

Delphi : Livebindings AfterScroll on TListView

I have a TListView and a TObjectList. I bind TFoo.value to Item.Caption.
I write a procedure "AfterScroll" with a showmessage inside. I connect the procedure on TBindSourceAdapter.AfterScroll.
I run this program and I have just one showmessage.
If I replace TListView by TStringGrid, I have the showmessage on each lines.
type
TFoo = class
private
FValue: string;
public
constructor create(sValue: string);
property Value: string read FValue write FValue;
end;
TForm5 = class(TForm)
PrototypeBindSource1: TPrototypeBindSource;
StringGrid1: TStringGrid;
BindingsList1: TBindingsList;
LinkGridToDataSourcePrototypeBindSource1: TLinkGridToDataSource;
ListView1: TListView;
LinkFillControlToField1: TLinkFillControlToField;
procedure PrototypeBindSource1CreateAdapter(Sender: TObject; var ABindSourceAdapter: TBindSourceAdapter);
private
{ Déclarations privées }
ListFoo: TObjectList<TFoo>;
procedure AfterScrool(Adapter: TBindSourceAdapter);
public
{ Déclarations publiques }
constructor create(AOwner: TComponent); override;
end;
var
Form5: TForm5;
implementation
{$R *.fmx}
{ TForm5 }
procedure TForm5.AfterScrool(Adapter: TBindSourceAdapter);
begin
ShowMessage('kk');
end;
constructor TForm5.create(AOwner: TComponent);
begin
ListFoo := TObjectList<TFoo>.create();
ListFoo.Add(TFoo.create('Test'));
ListFoo.Add(TFoo.create('Test 1'));
ListFoo.Add(TFoo.create('Test 2'));
ListFoo.Add(TFoo.create('Test 3'));
inherited create(AOwner);
end;
procedure TForm5.PrototypeBindSource1CreateAdapter(Sender: TObject; var ABindSourceAdapter: TBindSourceAdapter);
begin
ABindSourceAdapter := TListBindSourceAdapter<TFoo>.create(self, ListFoo);
ABindSourceAdapter.AfterScroll := AfterScrool;
end;
{ TFoo }
constructor TFoo.create(sValue: string);
begin
inherited create;
FValue := sValue;
end;
end.
It is possible to connect an "AfterScroll" event on a TListView ?
I found, we need to bind "*" on "Synch" property of TListView

published property class in delphi component

I am having a problem creating a lookup component.
I will try again ... put the images to facilitate ....
does not save the values of properties in the dfm ... so why, my properties are grouped in a class ... if they were "loose" would perform the setter method ...
my doubt is ... why not run?
I thank you ...
My class of properties
TLookupProperties = class(TPersistent)
private
FDataCharCase: TEditCharCase;
FOnLookupBeforeSearch: TNotifyEvent;
FDataSource: TDataSource;
FOnButtonClick: TNotifyEvent;
FDataTabela: string;
FOnExit: TNotifyEvent;
FDataCondicao: string;
FDataFieldDescricao: string;
FDataFieldCodigo: string;
FOnLookupValidate: TNotifyEvent;
FDataFieldID: String;
published
property OnLookupBeforeSearch: TNotifyEvent read FOnLookupBeforeSearch write FOnLookupBeforeSearch;
property OnLookupExit: TNotifyEvent read FOnExit write FOnExit;
property OnLookupButtonClick: TNotifyEvent read FOnButtonClick write FOnButtonClick;
property OnLookupValidate: TNotifyEvent read FOnLookupValidate write FOnLookupValidate;
property DataSource: TDataSource read FDataSource write FDataSource;
property DataFieldID: String read FDataFieldID write FDataFieldID;
property DataFieldCodigo: string read FDataFieldCodigo write FDataFieldCodigo;
property DataFieldDescricao: string read FDataFieldDescricao write FDataFieldDescricao;
property Condicao: string read FDataCondicao write FDataCondicao;
property Tabela: string read FDataTabela write FDataTabela;
property CharCase: TEditCharCase read FDataCharCase write FDataCharCase;
end;
My component
TDBLookupFrame = class(TFrame)
PnlTotal: TPanel;
btnButton: TSpeedButton;
edtCodigo: TDBEdit;
lblDescricao: TDBText;
procedure edtCodigoExit(Sender: TObject);
procedure btnButtonClick(Sender: TObject);
procedure edtCodigoKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure edtCodigoKeyPress(Sender: TObject; var Key: Char);
strict private
procedure SetarResult(AZerar: Boolean = False);
procedure Validar(Sender: TObject);
private
FLookupView: TLookupView;
FLookupProperties: TLookupProperties;
procedure SetLookupProperties(const Value: TLookupProperties);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property LookupProperties: TLookupProperties read FLookupProperties write SetLookupProperties;
end;
procedure register;
implementation
uses System.SysUtils;
{$R *.dfm}
procedure register;
begin
RegisterComponents('Hebran',[TDBLookupFrame]);
end;
procedure TDBLookupFrame.SetLookupProperties(const Value: TLookupProperties);
begin
FLookupProperties := Value;
edtCodigo.CharCase := FLookupProperties.CharCase;
FLookupView.Tabela := FLookupProperties.Tabela;
FLookupView.CondicaoAdicional := FLookupProperties.Condicao;
if Assigned(FLookupProperties.DataSource) then
begin
edtCodigo.DataSource := FLookupProperties.DataSource;
lblDescricao.DataSource := FLookupProperties.DataSource;
FLookupProperties.DataFieldDescricao := FLookupProperties.DataFieldCodigo;
lblDescricao.DataField := FLookupProperties.DataFieldDescricao;
end;
end;
constructor TDBLookupFrame.Create(AOwner: TComponent);
begin
inherited;
FLookupView := TLookupView.Create(Nil);
FLookupProperties := TLookupProperties.Create;
LookupProperties.Condicao := '';
LookupProperties.CharCase := ecNormal;
end;
Looking here (which is called while streaming the DFM into your component):
procedure TDBLookupFrame.SetLookupProperties(const Value: TLookupProperties);
begin
FLookupProperties := Value;
edtCodigo.CharCase := FLookupProperties.CharCase;
FLookupView.Tabela := FLookupProperties.Tabela;
FLookupView.CondicaoAdicional := FLookupProperties.Condicao;
if Assigned(FLookupProperties.DataSource) then
begin
edtCodigo.DataSource := FLookupProperties.DataSource;
lblDescricao.DataSource := FLookupProperties.DataSource;
FLookupProperties.DataFieldDescricao := FLookupProperties.DataFieldCodigo;
lblDescricao.DataField := FLookupProperties.DataFieldDescricao;
end;
end;
You are calling
FLookupProperties := Value;
Indeed, when relying on the IDE to auto-complete this for you, it too adds this. However, based on your situation, you should not be assigning a pointer - because you're now referencing the original instance of TLookupProperties and replacing the pointer to your copy. This also leaks memory, You already created FLookupProperties in the constructor, but can't reference that instance anymore because you've replaced the pointer.
You should instead be calling
FLookupProperties.Assign(Value);
This will ensure you create a full copy of the original value instead of just referencing the instance (which may or may not have been free'd after that point).
Your TLookupProperties should also be overriding TPersistent.Assign so that you can perform the appropriate copying of data from one instance to the other. Again, for any type of other TPersistent properties, don't use := because that just copies the pointer. Instead, use .Assign on them as well.
Try something more like this instead:
interface
uses
Classes, Forms, ...;
type
TDBLookupFrame = class;
TLookupProperties = class(TPersistent)
private
FOwner: TDBLookupFrame;
FDataCharCase: TEditCharCase;
FDataSource: TDataSource;
FDataTabela: string;
FDataCondicao: string;
FDataFieldDescricao: string;
FDataFieldCodigo: string;
FDataFieldID: String;
FOnChange: TNotifyEvent;
FOnButtonClick: TNotifyEvent;
FOnExit: TNotifyEvent;
FOnLookupBeforeSearch: TNotifyEvent;
FOnLookupValidate: TNotifyEvent;
procedure Changed;
procedure SetDataSource(const: Value: TDataSource);
procedure SetDataFieldID(const Value: String);
procedure SetDataFieldCodigo(const Value: string);
procedure SetDataFieldDescricao(const Valu: string);
procedure SetCondicao(const Value: string);
procedure SetTabela(const Value: string);
procedure SetCharCase(const Value: TEditCharCase);
public
constructor Create(AOwner: TDBLookupFrame);
procedure Assign(Source: TPeristent); override;
published
property DataSource: TDataSource read FDataSource write SetDataSource;
property DataFieldID: String read FDataFieldID write SetDataFieldID;
property DataFieldCodigo: string read FDataFieldCodigo write SetDataFieldCodigo;
property DataFieldDescricao: string read FDataFieldDescricao write SetDataFieldDescricao;
property Condicao: string read FDataCondicao write SetDataCondicao;
property Tabela: string read FDataTabela write SetDataTabela;
property CharCase: TEditCharCase read FDataCharCase write SetDataCharCase;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
property OnLookupBeforeSearch: TNotifyEvent read FOnLookupBeforeSearch write FOnLookupBeforeSearch;
property OnLookupExit: TNotifyEvent read FOnExit write FOnExit;
property OnLookupButtonClick: TNotifyEvent read FOnButtonClick write FOnButtonClick;
property OnLookupValidate: TNotifyEvent read FOnLookupValidate write FOnLookupValidate;
end;
TDBLookupFrame = class(TFrame)
PnlTotal: TPanel;
btnButton: TSpeedButton;
edtCodigo: TDBEdit;
lblDescricao: TDBText;
procedure edtCodigoExit(Sender: TObject);
procedure btnButtonClick(Sender: TObject);
procedure edtCodigoKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure edtCodigoKeyPress(Sender: TObject; var Key: Char);
strict private
procedure SetarResult(AZerar: Boolean = False);
procedure Validar(Sender: TObject);
private
FLookupView: TLookupView;
FLookupProperties: TLookupProperties;
procedure LookupPropertiesChanged(Sender: TObject);
procedure SetLookupProperties(const Value: TLookupProperties);
protected
procedure Loaded; override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property LookupProperties: TLookupProperties read FLookupProperties write SetLookupProperties;
end;
procedure Register;
implementation
uses
System.SysUtils;
{$R *.dfm}
constructor TLookupProperties.Create(AOwner: TDBLookupFrame);
begin
inherited Create;
FOwner := AOwner;
FDataCondicao := '';
FDataCharCase := ecNormal;
end;
procedure TLookupProperties.Changed;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
procedure TLookupProperties.SetDataSource(const: Value: TDataSource);
begin
if FDataSource <> Value then
begin
if FDataSource <> nil then
FDataSource.RemoveFreeNotification(FOwner);
FDataSource := Value;
if FDataSource <> nil then
FDataSource.FreeNotification(FOwner);
Changed;
end;
end;
procedure TLookupProperties.SetDataFieldID(const Value: String);
begin
if FDataFieldID <> Value then
begin
FDataFieldID := Value;
Changed;
end;
end;
procedure TLookupProperties.SetDataFieldCodigo(const Value: string);
begin
if FDataFieldCodigo <> Value then
begin
FDataFieldCodigo := Value;
Changed;
end;
end;
procedure TLookupProperties.SetDataFieldDescricao(const Valu: string);
begin
if FDataFieldDescricao <> Value then
begin
FDataFieldDescricao := Value;
Changed;
end;
end;
procedure TLookupProperties.SetCondicao(const Value: string);
begin
if FDataCondicao <> Value then
begin
FDataCondicao := Value;
Changed;
end;
end;
procedure TLookupProperties.SetTabela(const Value: string);
begin
if FDataTabela <> Value then
begin
FDataTabela := Value;
Changed;
end;
end;
procedure TLookupProperties.SetCharCase(const Value: TEditCharCase);
begin
if FDataCharCase <> Value then
begin
FDataCharCase := Value;
Changed;
end;
end;
procedure TLookupProperties.Assign(Source: TPeristent);
var
Src: TLookupProperties;
begin
if Source is TLookupProperties then
begin
Src := TLookupProperties(Source);
FDataCharCase := Src.FDataCharCase;
SetDataSource(Src.FDataSource);
FDataTabela := Src.FDataTabela;
FDataCondicao := Src.FDataCondicao;
FDataFieldDescricao := Src.FDataFieldDescricao;
FDataFieldCodigo := Src.FDataFieldCodigo;
FDataFieldID := Src.FDataFieldID;
Changed;
end else
inherited;
end;
constructor TDBLookupFrame.Create(AOwner: TComponent);
begin
inherited;
FLookupView := TLookupView.Create(nil);
FLookupProperties := TLookupProperties.Create(Self);
end;
destructor TDBLookupFrame.Destroy;
begin
FLookupView.Free;
FLookupProperties.Free;
inherited;
end;
procedure TDBLookupFrame.Loaded;
begin
inherited;
LookupPropertiesChanged(nil);
end;
procedure TDBLookupFrame.Notification(AComponent: TComponent; Operation: TOperation);
begin
inherited;
if (AComponent = FLookupProperties.FDataSource) and (Operation = opRemove) then
FLookupProperties.FDataSource := nil;
end;
procedure TDBLookupFrame.LookupPropertiesChanged(Sender: TObject);
begin
if (ComponentState * [csLoading, csReading]) <> [] then
Exit;
edtCodigo.CharCase := FLookupProperties.CharCase;
FLookupView.Tabela := FLookupProperties.Tabela;
FLookupView.CondicaoAdicional := FLookupProperties.Condicao;
edtCodigo.DataSource := FLookupProperties.DataSource;
lblDescricao.DataSource := FLookupProperties.DataSource;
FLookupProperties.DataFieldDescricao := FLookupProperties.DataFieldCodigo;
lblDescricao.DataField := FLookupProperties.DataFieldDescricao;
end;
procedure TDBLookupFrame.SetLookupProperties(const Value: TLookupProperties);
begin
if FLookupProperties <> Value then
FLookupProperties.Assign(Value);
end;
procedure Register;
begin
RegisterComponents('Hebran', [TDBLookupFrame]);
end;
sorry but my example is simple ... the problem is that the class does not perform the set of property TProperties class, then, does not save the values in .dfm to put the dataSource and dataField properties directly on my component, it performs the set and writes to the dfm, however, when you open a form with my component, property values saved in the dfm are not found ... (error Ex: property datasource not found)

TList descendant with another otbject?

I need to impliment a TList descendant of controls + an extra object.
something like:
List.Add(AControl, AObject)
So The List will hold both AControl, AObject
What is the best way of doing this with Delphi 7?
You can store a list of records, then you can put whatever you want into the record, eg:
type
PMyRecord = ^MyRecord;
MyRecord = record
Control: TControl;
Object: TObject;
end;
var
Rec: PMyRecord;
begin
New(Rec);
try
Rec.Control := AControl;
Rec.Object := AObject;
List.Add(Rec);
except
Dispose(Rec);
Raise;
end;
end;
var
Rec: PMyRecord;
begin
Rec := PMyRecord(List[SomeIndex]);
// use Rec.Control and Rec.Object as needed...
end;
Don't forget to Dispose() an item when you remove it from the list:
var
Rec: PMyRecord;
begin
Rec := PMyRecord(List[SomeIndex]);
List.Delete(SomeIndex);
Dispose(Rec);
end;
And also when you are finished using the list, or at least when you Clear() it:
var
I: Integer;
Rec: PMyRecord;
begin
for I := o to List.Count-1 do
Dispose(PMyRecord(List[I]));
//...
end;
If you derive a new class from TList, you can override its virtual Notify() method to dispose items:
type
TMyList = class(TList)
protected
function Get(Index: Integer): PMyRecord;
procedure Notify(Ptr: Pointer; Action: TListNotification); override;
public
function Add(AControl: TControl; AObject: TObject): Integer;
procedure Insert(Index: Integer; AControl: TControl; AObject: TObject);
property Items[Index: Integer]: PMyRecord read Get; default;
end;
function TMyList.Add(AControl: TControl; AObject: TObject): Integer;
var
Rec: PMyRecord;
begin
New(Rec);
try
Rec.Control := AControl;
Rec.Object := AObject;
Result := inherited Add(Rec);
except
Dispose(Rec);
Raise;
end;
end;
procedure TMyList.Insert(Index: Integer; AControl: TControl; AObject: TObject);
var
Rec: PMyRecord;
begin
New(Rec);
try
Rec.Control := AControl;
Rec.Object := AObject;
inherited Insert(Index, Rec);
except
Dispose(Rec);
Raise;
end;
end;
function TMyList.Get(Index: Integer): PMyRecord;
begin
Result := PMyRecord(inherited Get(Index));
end;
procedure TMyList.Notify(Ptr: Pointer; Action: TListNotification);
begin
inherited;
if Action = lnDeleted then
Dispose(PMyRecord(Ptr));
end;
try this
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TMyContainer = class
public
ctnGen: TControl;
objGen: TObject;
constructor Create(const ctnGen: TControl; const objGen: TObject);
end;
var
Form1: TForm1;
implementation
uses
Contnrs;
{$R *.DFM}
{ TMyContainer }
constructor TMyContainer.Create(const ctnGen: TControl;
const objGen: TObject);
begin
inherited Create();
Self.ctnGen := ctnGen;
Self.objGen := objGen;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
lstGen: TObjectList;
begin
lstGen := TObjectList.Create(True);
try
lstGen.Add(TMyContainer.Create(Self, Self));
ShowMessage(TMyContainer(lstGen.Items[0]).objGen.ClassName);
finally
lstGen.Free;
end;
end;
TObjectList will free the TMyContainer class

Why a published Int64 property-writer method wouldn't be called - Component streaming

Here is a simple test demonstrating the issue I encounter in a project, using Delphi 2007. I use a TComponent class for storing various states of a component. But the Int64 property writer methods are never called (only the destination field is set). So it's not possible to rely on the writer to update a GUI a TList or such things...
For example:
TTestClass = Class(TComponent)
Private
Fb: Int64;
Fa: Integer;
Procedure SetFa(Const Value: Integer);
Procedure SetFb(Const Value: Int64);
Published
Property a: Integer Read Fa Write SetFa;
Property b: Int64 Read Fb Write SetFb;
Public
Procedure SaveInstance(Var Str: TStream);
Procedure LoadInstance(Var Str: TStream);
Procedure ReallyLoadInstance(Var Str: TStream);
Procedure Assign(Source: TPersistent); Override;
End;
TForm1 = Class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Procedure Button1Click(Sender: TObject); // test: 1st step, save the class
Procedure Button2Click(Sender: TObject); // test: 2nd step, try and fail to reload
Procedure Button3Click(Sender: TObject); // test: 3rd step, successfull reloading
Private
TestClass: TTestClass;
Str: TStream;
Public
Constructor Create(AOwner: TComponent); Override;
Destructor Destroy; Override;
End;
Var
Form1: TForm1;
Implementation
{$R *.dfm}
Procedure TTestClass.SetFa(Const Value: Integer);
Begin
Fa := Value;
ShowMessage('ok for "simple types"....');
End;
Procedure TTestClass.SetFb(Const Value: Int64);
Begin
Fb := Value;
ShowMessage('and for the others');
End;
Procedure TTestClass.SaveInstance(Var Str: TStream);
Begin
Str.Position := 0;
Str.WriteComponent( Self );
End;
Procedure TTestClass.Assign(Source: TPersistent);
Begin
If Not (Source Is TTestClass) Then Inherited
Else
Begin
b := TTestClass(Source).Fb;
End;
End;
Procedure TTestClass.LoadInstance(Var Str: TStream);
Begin
Str.Position := 0;
// this will work for fa and not fb.
Str.ReadComponent(Self);
End;
Procedure TTestClass.ReallyLoadInstance(Var Str: TStream);
Begin
Str.Position := 0;
Assign( Str.ReadComponent(Nil));
End;
Constructor TForm1.Create(AOwner: TComponent);
Begin
RegisterClasses([TTestClass]);
Inherited;
TestClass := TTestClass.Create(Self);
Str := TmemoryStream.Create;
End;
Destructor TForm1.Destroy;
Begin
Str.Free;
Inherited;
End;
Procedure TForm1.Button1Click(Sender: TObject);
Begin
Str.Size := 0;
TestClass.SaveInstance(Str);
End;
Procedure TForm1.Button2Click(Sender: TObject);
Begin
If Str.Size = 0 Then Exit;
TestClass.LoadInstance(Str);
// guess what...only first message
End;
Procedure TForm1.Button3Click(Sender: TObject);
Begin
If Str.Size = 0 Then Exit;
TestClass.ReallyLoadInstance(Str);
End;
As in TypInfo.pas there is a 'tkInt64' case (which seems to call a "SetProc" procedure), Shouldn't published-Int64-props be set using the "Writer" ( as done usually with other "common" types) ?
That's because you never assign a value to property b. Thus it has the default value (zero) and the streaming system won't save it to the stream. And since it isn't in the stream, you won't see the setter called when reading it back...
Actually, since you don't assign value to property a either, same thing should happen with it. Looks like a bug (or at least inconsistency) in the streaming system:
either it shouldn't save/load the Integer property with zero value to the stream too,
or it should save/load both of them as there is no default specifier in the properties definition and thus nodefault should be assumed and thus the value always to be streamed.
So, to recap: add TestClass.b := 1; before calling TestClass.SaveInstance(Str); and you should see the setter called when loading the object back from stream, but you can't relay on the streaming system to call the setter when property has the default value of the type.
This seems to be a bug with Int64 as a property.
As a workaround you could either use another data type, like Integer, or, if that is not big enough, use DefineProperties and TFiler.DefineProperty, TFiler.DefineBinaryProperty, etc.

Resources