You are not logged in.
Hello,
I have created a form inheriting class (TRTTIForm), copiando quanto c'è scritto nella unit SQLite3UIEdit, I have attached the code below:
unit UFrmEditBase;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, ActnList, StdCtrls, ExtCtrls, AdvPanel,
SQLite3UIEdit,
SynCommons, SynCrypto, SynGdiPlus,
SQLite3Commons,
SQLite3UILogin,
SQLite3UI,
SQLite3i18n,SQLite3ToolBar, AdvGlowButton
;
type
TFrmEditBase = class(TRTTIForm)
ActionList1: TActionList;
ActAdd: TAction;
ActRemove: TAction;
ActSave: TAction;
ActCancel: TAction;
ActClose: TAction;
PopupMenu1: TPopupMenu;
Nuovo1: TMenuItem;
Annulla1: TMenuItem;
Chiudi1: TMenuItem;
Chiudi2: TMenuItem;
Salva1: TMenuItem;
N1: TMenuItem;
N2: TMenuItem;
Scroll: TScrollBox;
BottomPanel: TPanel;
BtnSave: TAdvGlowButton;
BtnCancel: TAdvGlowButton;
procedure FormShow(Sender: TObject);
procedure ActSaveExecute(Sender: TObject);
procedure ActCancelExecute(Sender: TObject);
private
procedure Save(Sender: TObject);
protected
fRec: TSQLRecord;
fClient: TSQLRestClient;
ADatabase: TSQLRestClient;
fOnComponentValidate: TOnComponentValidate;
/// as created by SetRecord()
fFieldComponents: array of TWinControl;
fFieldCaption: array of string;
// avoid Windows Vista and Seven screen refresh bug (at least with Delphi 7)
fReadOnly: boolean;
procedure WMUser(var Msg: TMessage); message WM_USER;
public
/// create the corresponding components on the dialog for editing a Record
// - to be used by OnComponentCreate(nil,nil,EditForm) in order
// to populate the object tree of this Form
// - create field on the window for all published properties of the
// supplied TSQLRecord instance
// - properties which name starts by '_' are not added to the UI window
// - user can customize the component creation by setting the
// OnComponentCreate / OnComponentCreated events
// - the supplied aRecord instance must be available during all the
// dialog window modal apparition on screen
// - by default, all published fields are displayed, but you can specify
// a CSV list in the optional CSVFieldNames parameter
// - editor parameters are taken from the optional Ribbon parameter,
// and its EditFieldHints/EditExpandFieldHints/EditFieldNameWidth properties
// - if Ribbon is nil, FieldHints may contain the hints to be displayed on
// screen (useful if your record is not stored in any TSQLRestClient, but
// only exists in memory); you can set FieldNamesWidth by hand in this case
procedure SetRecord(aClient: TSQLRestClient; aRecord: TSQLRecord;
CSVFieldNames: PUTF8Char=nil; Ribbon: TSQLRibbon=nil;
FieldHints: string=''; FieldNamesWidth: integer=0; aCaption: string='');
/// the associated Record to be edited
property Rec: TSQLRecord read fRec;
/// the associated database Client, used to access remote data
property Client: TSQLRestClient read fClient;
/// event called to check if the content of a field on form is correct
// - is checked when the user press the "Save" Button
// - if returns false, component is focused and window is not closed
property OnComponentValidate: TOnComponentValidate read fOnComponentValidate write fOnComponentValidate;
property ReadOnly: boolean read fReadOnly write fReadOnly;
end;
var
FrmEditBase: TFrmEditBase;
function Cypher(const Title: string; var Content: TSQLRawBlob; Encrypt: boolean): boolean;
implementation
{$R *.dfm}
resourcestring
sEdit = 'Edit';
sVerb = '%s %s';
sInvalidFieldN = 'Invalid "%s" Field';
procedure TFrmEditBase.SetRecord(aClient: TSQLRestClient;
aRecord: TSQLRecord; CSVFieldNames: PUTF8Char=nil; Ribbon: TSQLRibbon=nil;
FieldHints: string=''; FieldNamesWidth: integer=0; aCaption: string='');
var i,j, aID, Y, aHeight, aWidth, CW: integer;
RibbonParams: PSQLRibbonTabParameters;
ExpandFieldHints: boolean;
E: PEnumType;
EP: PShortString;
Group: TGroupBox;
C: TWinControl;
CLE: TLabeledEdit absolute C;
CNE: TSynLabeledEdit absolute C;
CC: TCheckbox absolute C;
CB: TCombobox absolute C;
aClassType: TSQLRecordClass;
Sets: cardinal;
IDClass: TSQLRecordClass;
aHint: string;
aName: RawUTF8;
FieldNameToHideCSV: PUTF8Char;
P: PPropInfo;
PHint: PChar; // map FieldHints
begin
if (self=nil) or (aRecord=nil) then
exit; // avoid GPF
RibbonParams := Ribbon.GetParameter(aRecord.RecordClass);
if RibbonParams=nil then begin
ExpandFieldHints := (FieldHints<>'');
FieldNameToHideCSV := nil;
if FieldNamesWidth=0 then
FieldNamesWidth := 200; // default value
end else
with RibbonParams^ do begin
FieldNamesWidth := EditFieldNameWidth;
if FieldNamesWidth=0 then
FieldNamesWidth := 200; // default value
if EditFieldHints<>nil then
FieldHints := LoadResString(EditFieldHints);
ExpandFieldHints := EditExpandFieldHints;
FieldNameToHideCSV := pointer(EditFieldNameToHideCSV);
end;
fRec := aRecord;
fClient := aClient;
CW := Scroll.ClientWidth;
aName := aClient.MainFieldValue(aRecord.RecordClass,aRecord.ID,true);
if aCaption='' then begin
if Caption='' then
aCaption := sEdit else
aCaption := Caption;
aCaption := format(sVerb,[aCaption,aRecord.CaptionName]);
if aName<>'' then
aCaption := aCaption+' - '+U2S(aName); // add current record name
end;
Caption := ' '+aCaption;
with TStaticText.Create(Scroll) do begin
Parent := Scroll;
Alignment := taCenter;
Font.Style := [fsBold];
Font.Size := 12;
Font.Color := clTeal;
Caption := aCaption;
SetBounds(8,16,CW-48,Height);
Y := Top+Height+16;
end;
with TBevel.Create(Scroll) do begin
Parent := Scroll;
SetBounds(8,Y-12,CW-32,4);
Shape := bsTopLine;
end;
aClassType := PPointer(aRecord)^;
dec(CW,FieldNamesWidth+32);
PHint := pointer(FieldHints);
with aClassType.RecordProps do begin
SetLength(fFieldComponents,length(Fields));
SetLength(fFieldCaption,length(Fields));
for i := 0 to High(Fields) do begin
aHint := GetNextItemString(PHint,'|'); // ALL fields are listed: do it now
P := Fields[i];
aName := FieldsName[i];
if ((FieldType[i] in [ // must match case "FieldType[i] of" below
sftRecord, sftTimeLog, sftCurrency, sftDateTime, sftFloat, sftBlob]) and
not Assigned(OnComponentCreate)) or
((FieldNameToHideCSV<>nil) and
(FindCSVIndex(FieldNameToHideCSV,aName,',',false)>=0)) or
((CSVFieldNames<>nil) and
(FindCSVIndex(CSVFieldNames,aName,',',false)<0)) then
continue; // display properties listed in optional CSVFieldNames parameter
aCaption := CaptionName(OnCaptionName,@P^.Name);
fFieldCaption[i] := aCaption;
if (aHint<>'') and ExpandFieldHints then
with TLabel.Create(Scroll) do begin // show hint above field
Parent := Scroll;
Font.Color := clNavy;
Font.Size := 8;
AutoSize := True;
WordWrap := true;
SetBounds(FieldNamesWidth,Y+8,CW-32,24);
Caption:= aHint;
inc(Y,Height+10);
aHint := ''; // mark hint displayed on window -> no popup needed
end;
aHeight := 24;
// try custom component creation
if not Assigned(OnComponentCreate) then
C := nil else
C := OnComponentCreate(aRecord,P,Scroll);
if C=nil then begin
// default creation from RTTI, if not handled by OnComponentCreate()
case FieldType[i] of
sftRecord, sftTimeLog, sftCurrency, sftDateTime, sftFloat, sftBlob:
; // not implemented yet (not needed yet, to be honest)
sftInteger:
// integer field is handled by a TSynLabeledEdit component
if P^.PropType^^.Kind=tkInteger then begin // tkInt64 not handled yet
CNE := TSynLabeledEdit.Create(Scroll);
CNE.Value := P^.GetOrdValue(aRecord);
CNE.RaiseExceptionOnError := true; // force show errors on screen
end;
sftEnumerate: begin
// enumeration is handled by a TComboBox with all possible values
E := P^.PropType^^.EnumBaseType;
CB := TComboBox.Create(Scroll);
CB.Parent := Scroll; // need parent now for CB.Items access
CB.Style := csDropDownList;
EP := @E^.NameList;
for j := 0 to E^.MaxValue do begin
CB.Items.Add(CaptionName(OnCaptionName,EP));
inc(PtrInt(EP),ord(EP^[0])+1); // next enumeration item
end;
CB.ItemIndex := P^.GetOrdValue(aRecord);
end;
sftID:
if aClient<>nil then begin
// ID field (TSQLRecord descendant) is handled by a TComboBox component
// with all possible values of the corresponding TSQLRecord descendant
IDClass := TSQLRecordClass(P^.PropType^^.ClassType^.ClassType);
CB := TComboBox.Create(Scroll);
CB.Parent := Scroll; // need parent now for CB.Items access
CB.Style := csDropDownList;
aID := P^.GetOrdValue(aRecord);
with IDClass.RecordProps do
if MainField[true]>=0 then begin
aClient.OneFieldValues(IDClass,FieldsName[MainField[true]],'',CB.Items,@aID);
CB.ItemIndex := aID; // @aID now contains the found index of aID
end;
end;
sftSet: begin
// enumeration set if handled by a TGroupBox component contaning one
// TCheckBox for each enumeration value
Group := TGroupBox.Create(Scroll); // add left-sided label
Group.Parent := Scroll;
Group.Font.Style := [fsBold];
Group.Caption := ' '+aCaption+' ';
Group.Tag := i+1; // for BtnSaveClick() event
if Assigned(OnComponentCreated) then // allow component customization
OnComponentCreated(aRecord,P,Group); // e.g. set Group.Enabled := false
Sets := P^.GetOrdValue(aRecord);
E := P^.PropType^^.SetEnumType;
aWidth := 200;
EP := @E^.NameList;
for j := 0 to E^.MaxValue do begin
if EP^[0]>#25 then begin
aWidth := 250; // wider group box for large enumeration caption
break;
end;
inc(PtrInt(EP),ord(EP^[0])+1); // next enumeration item
end;
Group.SetBounds(FieldNamesWidth,Y+4,aWidth,40+20*E.MaxValue);
dec(aWidth,20);
EP := @E^.NameList;
for j := 0 to E^.MaxValue do
with TCheckBox.Create(Scroll) do begin // add set checkboxes
Parent := Group;
Font.Style := [];
Caption := CaptionName(OnCaptionName,EP);
inc(PtrInt(EP),ord(EP^[0])+1); // next enumeration item
SetBounds(16,16+20*j,aWidth,20);
if aHint<>'' then begin
Hint := aHint;
ShowHint := True;
end;
Checked := GetBit(Sets,j);
Enabled := Group.Enabled;
Tag := i+1+(j+1) shl 8; // for BtnSaveClick() event
end;
inc(Y,Group.Height+12);
continue;
end;
sftBoolean: begin
// boolean is handled by a TCheckBox component
CC := TCheckBox.Create(Scroll);
CC.Parent := Scroll; // initialize font
CC.Font.Style := [fsBold];
CC.Checked := boolean(P^.GetOrdValue(aRecord));
CC.Caption := aCaption;
end;
sftUTF8Text, sftAnsiText: begin
// text field is handled by a TLabeledEdit component
CLE := TLabeledEdit.Create(Scroll);
{$ifdef UNICODE}
if P^.PropType^^.Kind=tkUString then
CLE.Text := P^.GetUnicodeStrValue(aRecord) else
{$endif}
CLE.Text := U2S(P^.GetValue(aRecord,False)); // convert in GetValue()
CLE.Name := P^.Name;
end;
end;
end;
if (C<>nil) and (C<>self) and (C<>Scroll) then begin
// we reached here if a component was added on screen for this field
C.Parent := Scroll;
C.Tag := i+1; // for BtnSaveClick() event
if aHint<>'' then begin
C.Hint := aHint; // show hint text as popup
C.ShowHint := true;
end;
if Assigned(OnComponentCreated) then // allow component customization
OnComponentCreated(aRecord,P,C); // e.g. set C.Enabled := false
if not C.InheritsFrom(TCheckBox) then
if C.InheritsFrom(TLabeledEdit) then begin
CLE.EditLabel.Font.Style := [fsBold];
CLE.EditLabel.Caption := aCaption;
CLE.LabelPosition := lpLeft;
end else
with TLabel.Create(Scroll) do begin // add label left-sided to the field
Parent := Scroll;
Font.Style := [fsBold];
Caption := aCaption;
SetBounds(8,Y+4,FieldNamesWidth-12,Height);
Alignment := taRightJustify;
if not C.Enabled then
Enabled := false;
end;
if C.InheritsFrom(TCheckBox) then // trick to avoid black around box
CC.SetBounds(FieldNamesWidth,Y,CW,CC.Height) else
C.SetBounds(FieldNamesWidth,Y,200,22);
fFieldComponents[i] := C;
inc(Y,aHeight);
end;
end;
end;
// draw a line at the bottom of the scroll box
with TBevel.Create(Scroll) do begin
Parent := Scroll;
SetBounds(8,Y+8,CW+FieldNamesWidth,16);
Shape := bsTopLine;
end;
Inc(Y,BottomPanel.Height+32);
// resize height to fit the fields (avoid bottom gap)
if ClientHeight>Y then
ClientHeight := Y;
end;
procedure TFrmEditBase.ActCancelExecute(Sender: TObject);
begin
modalresult := mrCancel;
end;
procedure TFrmEditBase.ActSaveExecute(Sender: TObject);
begin
Save(Sender);
end;
procedure TFrmEditBase.FormShow(Sender: TObject);
begin
Application.ProcessMessages;
Screen.Cursor := crHourGlass;
try
if Assigned(OnComponentCreate) then
OnComponentCreate(nil,nil,self); // will call AddEditors() to create nodes
SetStyle(self);
finally
Screen.Cursor := crDefault;
end;
PostMessage(Handle,WM_USER,0,0); // avoid Vista and Seven screen refresh bug
end;
procedure TFrmEditBase.WMUser(var Msg: TMessage);
var i: integer;
begin
for i := 0 to Scroll.ControlCount-1 do
Scroll.Controls[i].Repaint;
end;
procedure TFrmEditBase.Save(Sender: TObject);
var j, FieldIndex, SetIndex, aID: integer;
Value: set of 0..31;
U: RawUTF8;
C: TWinControl;
CLE: TLabeledEdit absolute C;
CNE: TSynLabeledEdit absolute C;
CC: TCheckbox absolute C;
CB: TCombobox absolute C;
CG: TGroupBox absolute C;
Props: TSQLRecordProperties;
P: PPropInfo;
ModifiedFields: TSQLFieldBits;
ErrMsg: string;
begin
if Rec=nil then
exit;
Props := Rec.RecordProps;
Int64(ModifiedFields) := 0;
for FieldIndex := 0 to high(fFieldComponents) do begin
C := fFieldComponents[FieldIndex];
if (C=nil) or not C.Enabled then
continue; // disabled components didn't modify their value
assert(FieldIndex=(C.Tag and 255)-1);
P := Props.Fields[FieldIndex];
if Assigned(OnComponentValidate) and not OnComponentValidate(C,P) then begin
// invalid field content -> abort saving
C.SetFocus;
exit;
end;
if C.InheritsFrom(TSynLabeledEdit) then
try
P^.SetOrdValue(Rec,CNE.Value); // call CNE.GetValue for range checking
Include(ModifiedFields,FieldIndex);
except
on E: ESynLabeledEdit do begin // trigerred by CNE.GetValue
CNE.SetFocus;
ShowMessage(CNE.EditLabel.Caption+':'#13+E.Message,true);
exit;
end;
end else
if C.InheritsFrom(TLabeledEdit) then begin
U := S2U(CLE.Text);
P^.SetValue(Rec,pointer(U)); // do conversion for every string type
Include(ModifiedFields,FieldIndex);
end else
if C.InheritsFrom(TGroupBox) then begin
for j := 0 to CG.ControlCount-1 do
if CG.Controls[j].InheritsFrom(TCheckBox) then
with TCheckBox(CG.Controls[j]) do begin
SetIndex := (Tag shr 8)-1;
if cardinal(SetIndex)<32 then begin
integer(Value) := P^.GetOrdValue(Rec);
if Checked then
include(Value,SetIndex) else
exclude(Value,SetIndex);
P^.SetOrdValue(Rec,integer(Value));
Include(ModifiedFields,FieldIndex);
end;
end;
end else
if C.InheritsFrom(TCheckBox) then begin
if CC.Tag<255 then begin
P^.SetOrdValue(Rec,integer(CC.Checked));
Include(ModifiedFields,FieldIndex);
end;
end else
if C.InheritsFrom(TComboBox) then begin
SetIndex := CB.ItemIndex;
case P^.PropType^^.SQLFieldType of
sftEnumerate:
if SetIndex>=0 then begin
P^.SetOrdValue(Rec,SetIndex);
Include(ModifiedFields,FieldIndex);
end;
sftID: begin
if SetIndex<0 then
aID := 0 else
aID := PtrInt(CB.Items.Objects[SetIndex]);
P^.SetOrdValue(Rec,aID);
Include(ModifiedFields,FieldIndex);
end;
end;
end;
end;
// perform all registered filtering
Rec.Filter(ModifiedFields);
// perform content validation
FieldIndex := -1;
ErrMsg := Rec.Validate(Client,ModifiedFields,@FieldIndex);
if ErrMsg<>'' then begin
// invalid field content -> show message, focus component and abort saving
if cardinal(FieldIndex)<cardinal(length(fFieldComponents)) then begin
C := fFieldComponents[FieldIndex];
C.SetFocus;
Application.ProcessMessages;
ShowMessage(ErrMsg,format(sInvalidFieldN,[fFieldCaption[FieldIndex]]),true);
end else
ShowMessage(ErrMsg,format(sInvalidFieldN,['?']),true);
end else
begin
fClient.update(Rec);
// close window on success
ModalResult := mrOk;
end;
end;
function Cypher(const Title: string; var Content: TSQLRawBlob; Encrypt: boolean): boolean;
resourcestring
sEnterPassword = 'Enter password for this record:';
var AES: TAESFull;
SHA: TSHA256Digest;
PassWord: string;
Len: integer;
begin
result := Content='';
if result then
exit;
if not TLoginForm.PassWord(Title,sEnterPassword,PassWord) then
exit;
SHA256Weak(S2U(PassWord), SHA);
try
Len := AES.EncodeDecode(SHA,256,length(Content),Encrypt,nil,nil,Pointer(Content),nil);
if Len<0 then
exit;
SetString(Content,PAnsiChar(AES.outStreamCreated.Memory),Len);
result := true;
finally
AES.OutStreamCreated.Free;
end;
end;
end.
and it all works, the components are created "TLabeledEdit" etc. .. vost as in example, but when I refer to an object created at runtime what to write?
Let me explain with an example:
TSQLUser = class(TSQLFile)
private
fRoles: TSQLUserRoles;
fLogin, fPassword: RawUTF8;
fName : RawUTF8;
fSubName: RawUTF8;
....
function TFrmElencoUser.Edit(Rec: TSQLFile; const Title: string; ReadOnly: boolean): boolean;
var
refreshed:Boolean;
begin
fRec := TSQLUser(Rec);
try
FrmEditUser := TFrmEditUser.Create(Self); // TFrmEditUser = class(TFrmEditBase)
FrmEditUser.Caption := ' '+Title;
FrmEditUser.ReadOnly := ReadOnly;
FrmEditUser.SetRec(ADatabase,fRec);
....
end;
function TFrmEditUser.SetRec(aClient: TSQLRestClient;const Value: TSQLUser): boolean;
begin
result := false;
fRec := Value;
ADatabase := aClient;
SetRecord(ADatabase,Value);
.....
//now I want to change the value of a property by code
procedure TFrmEditUser.changeSubName(value:String);
begin
fRec.SubName := value; //now if I run the form's save the value of the property is replaced with the same property attached to TlabelEdit.text
end;
so I decided to write directly into TlabelEdit.text, but I do not know how to find the one attached to the property subname.
so I added the line "CLE.Name: = P ^. Name," to name the object created at runtime
sftUTF8Text, sftAnsiText: begin
// text field is handled by a TLabeledEdit component
CLE := TLabeledEdit.Create(Scroll);
{$ifdef UNICODE}
if P^.PropType^^.Kind=tkUString then
CLE.Text := P^.GetUnicodeStrValue(aRecord) else
{$endif}
CLE.Text := U2S(P^.GetValue(aRecord,False)); // convert in GetValue()
CLE.Name := P^.Name; // I added this line
end;
and I corrected the procedure "changeSubName" as follows:
procedure TFrmEditUser.changeSubName(value:String);
begin
fRec.SubName := value;
for i := 0 to Self.ControlCount-1 do
begin
if self.Controls[i] is TScrollBox then
begin
if self.Controls[i].findcomponent('SubName') is TLabeledEdit then
TLabeledEdit( self.Controls[i].findcomponent('SubName')).Text := fRec.SubName;
break;
end;
end;
The question is: is there some other way to achieve the same result?
Thanks
Offline
So you are "forking" our unit.
You have the fFieldComponents[] private array, which follows the RecordProps.Fields[] layout, so you can use RecordProps.FieldIndex or RecordProps.FieldIndexFromRawUTF8 to retrieve the editable field directly.
Offline
Ok I put this new procedure in the base form, and when I writing into a textbox I will write : SetValue('Fieldname','value');
procedure TFrmEditBase.SetValue(FieldName:String; Value: String);
var
FieldIndex:Integer;
C: TWinControl;
CLE: TLabeledEdit absolute C;
U: RawUTF8;
P: PPropInfo;
Props: TSQLRecordProperties;
begin
Props := fRec.RecordProps;
FieldIndex := Props.FieldIndexFromRawUTF8(FieldName);
if cardinal(Props.FieldIndexFromRawUTF8(FieldName))<cardinal(length(fFieldComponents)) then
begin
C := fFieldComponents[FieldIndex];
C.SetFocus;
if C.InheritsFrom(TLabeledEdit) then begin
begin
CLE.Text := Value;
U := S2U(CLE.Text);
P := Props.Fields[FieldIndex];
P^.SetValue(fRec,pointer(U)); // do conversion for every string type
end;
end
end;
end;
Thanks
Offline
Ok I put this new procedure in the base form, and when I writing into a textbox I will write : SetValue('Fieldname','value');
Nice.
I think you did understand a lot of low-level aspects of the framework (RTTI, unicode, and such).
Great!
Perhaps some modifications:
procedure TFrmEditBase.SetValue(const FieldName: RawUTF8; const Value: String);
var
FieldIndex: PtrUInt;
C: TWinControl;
CLE: TLabeledEdit absolute C;
Props: TSQLRecordProperties;
begin
Props := fRec.RecordProps;
FieldIndex := Props.FieldIndexFromRawUTF8(FieldName);
if FieldIndex<PtrUInt(length(fFieldComponents)) then
begin
C := fFieldComponents[FieldIndex];
C.SetFocus;
if C.InheritsFrom(TLabeledEdit) then begin
begin
CLE.Text := Value;
Props.Fields[FieldIndex]^.SetValue(fRec,pointer(S2U(Value))); // do conversion for every string type
end;
end;
end;
Last edited by ab (2011-04-15 11:46:04)
Offline