In my project there is a TADOQuery tdm_Company that gets filled with a set of fields, provided with proper labels and fields set to visible=false where appropriate.The query returns a single result.
I have a detail screen that needs a bunch of labels and edit textboxes for these fields.
Is it possible to auto generate these in the editor? What if I need those controls to be controls from the DevExpress components (TcxDBTextEdit and TcxLabel for example)?
I have never tried this, but there is (or was? - sorry, can't check) a Database Form Wizard. If you want to have other controls than those the wizard generates, there are possibilities to change these afterwards, e.g. GExperts' Replace Components.
In a very similar case (a query to return a single record showing contact data from an entity - company, customer etc.) we use DevExpress's TcxDBVerticalGrid. It scales much better and is more flexible (especially when resizing the form) when it comes to display a bunch of data which represents a single object.
Of course, you are not tied to the above component, you can obtain good results with (almost) any vertical grid / DBIspector but since you asked about a DevExpress component I gave you the above solution.
HTH
A long time ago I actually created my own Wizard for this, based on an actual Custom Form I wrote for a FrameWork of mine. When the Dialog for the wizard was shown, it would display all fields in a grid and allow the user to indicate which component should be used to display that field.
In my case depending on the Type of field it was prefilled with specific components (eg a TcxDateEdit for a TDateTime field, ...). The user could still change that though, and indicate which fields he wanted to add to the form. Once the user closes the form it was just matter of itterating over all the fields and creating the corresponding control.
Searched through my code and found this back :
{ Custom Devia Development Framework RecordView Module which adds functionality to
create the DB Aware Controls for the RecordView }
TDevFrameWorkRecordViewModule = class( TCustomModule )
protected
procedure CreateDBAwareComponents( aParent : TComponent; aDataSource : TDataSource; aFields : TFields; aFieldDefs : TFieldDefs ); virtual;
function DefaultWizardClass : TDBAwareControlWizardClass; virtual;
function DefaultLabelClass : TComponentClass; virtual;
function MaxFieldCaptionLength ( aFields : TFields ) : Integer; virtual;
protected
function GetSelectedComponents : IDesignerSelections;
function GetSelectedControl : TControl;
property SelectedControl : TControl read GetSelectedControl;
property SelectedComponents : IDesignerSelections read GetSelectedComponents;
public
procedure DevAddDBAwareComponentsWizard( aParent : TControl ); virtual;
procedure ExecuteVerb(Index: Integer); override;
function GetVerb(Index: Integer): string; override;
function GetVerbCount: Integer; override;
end;
...
procedure TDevFrameWorkRecordViewModule.CreateDBAwareComponents(
aParent : TComponent; aDataSource : TDataSource; aFields : TFields; aFieldDefs : TFieldDefs );
var
lcv : Integer;
aLabel : TControl;
aEdit : TWinControl;
aDataBinding : TcxDBEditDataBinding;
aTop , aLeft : Integer;
aWidth : Integer;
aMaxCaptionWidth: Integer;
aDBLeft : Integer;
aRecordView : IDevFrameWorkRecordView;
aDBAwareClass : TComponentClass;
aDBAwareVisible : Boolean;
aWizardForm : TfrmDevFrameWorkAddDataAwareControlsWizard;
begin
{ First make sure the procedure was triggered on a FrameWorkRecordView }
if ( Supports( Root, IDevFrameWorkRecordView, aRecordView ) ) then
begin
{ Now Create and Show the wizard so the user can specify all the options }
aWizardForm := DefaultWizardClass.Create( Nil );
try
aWizardForm.RecordDataSet := aRecordView.DataSource.DataSet;
aWizardForm.InitialiseSettings;
{ If the user closed the Wizard using the OK button, we can continue the
process }
if ( aWizardForm.ShowModal = mrOK ) then
begin
{ By default the label components should start at 8,8 in the Parent Container }
aTop := 8;
aLeft := 8;
aWidth:= 121;
aMaxCaptionWidth := MaxFieldCaptionLength( aFields );
{ Now set the intial Left Position for our DBAware controls according
to the MaxCaptionWidth }
aDBLeft := 24 + ( ( ( aMaxCaptionWidth div 8 ) + 1 ) * 8 );
{ Loop over all fields to create the Label and DBAwareComponent }
for lcv := 0 to Pred( aFields.Count ) do
begin
{ Get some settings from the Wizard form }
aDBAwareClass := aWizardForm.GetDBAwareComponentClass( aFields[ lcv ] );
aDBAwareVisible := aWizardForm.GetDBAwareComponentVisible( aFields[ lcv ] );
{ Only create the components if the user indicated he wants to see them }
if aDBAwareVisible then
begin
{ Now create the Label and the DBAware Control }
aLabel := TControl ( Designer.CreateComponent( DefaultLabelClass, aParent, aLeft , aTop, aMaxCaptionWidth, 17 ) );
aEdit := TWinControl( Designer.CreateComponent( aDBAwareClass, aParent, aDBLeft, aTop, aWidth, 21 ) );
{ Now Set the Label Properties }
aLabel.Name := Designer.UniqueName( 'cxlbl' + aFields[ lcv ].FieldName );
aLabel.HelpType := htKeyWord;
aLabel.HelpKeyword := Root.Name + '.' + aFields[ lcv ].FieldName;
{ Set the additional properties using RTTI }
if ( IsPublishedProp( aLabel, 'FocusControl' ) ) then
begin
SetObjectProp( aLabel, 'FocusControl', aEdit );
end;
if ( IsPublishedProp( aLabel, 'Caption' ) ) then
begin
SetStrProp( aLabel, 'Caption', aFields[ lcv ].DisplayLabel );
end;
{ Now set the Edit Properites }
aEdit.Name := Designer.UniqueName( {'cxlbl' +} aFields[ lcv ].FieldName );
aEdit.HelpType := htKeyWord;
aEdit.HelpKeyword := Root.Name + '.' + aFields[ lcv ].FieldName;
{ Set the additional properties using RTTI }
if ( IsPublishedProp( aEdit, 'DataBinding' ) ) then
begin
aDataBinding := TcxDBEditDataBinding( GetObjectProp( aEdit, 'DataBinding' ) );
SetObjectProp( aDataBinding, 'DataSource', aDataSource );
SetStrProp ( aDataBinding, 'DataField' , aFields[ lcv ].FieldName );
end;
if ( aEdit is TcxCustomDropDownEdit ) then
begin
aEdit.Width := aWidth + 16;
end;
{ Now increment the Top position for the next control }
inc( aTop, ( ( ( aEdit.Height div 8 ) + 1 ) * 8 ) );
end;
end;
end;
finally
FreeAndNil( aWizardForm );
end;
end;
end;
function TDevFrameWorkRecordViewModule.DefaultLabelClass: TComponentClass;
begin
Result := TLabel;
end;
function TDevFrameWorkRecordViewModule.DefaultWizardClass: TDBAwareControlWizardClass;
begin
Result := TfrmDevFrameWorkAddDataAwareControlsWizard;
end;
procedure TDevFrameWorkRecordViewModule.ExecuteVerb(Index: Integer);
var
aSelections : IDesignerSelections;
lcv : Integer;
begin
aSelections := TDesignerSelections.Create;
Designer.GetSelections( aSelections );
for lcv := 0 to Pred( aSelections.Count ) do
begin
{$IFDEF CODESITE}
csFWRecordView.Send( 'aSelection.Items[ lcv ]', aSelections.Items[ lcv ] );
{$ENDIF}
end;
Case Index of
0 : DevAddDBAwareComponentsWizard( SelectedControl );
else Inherited ExecuteVerb( Index );
end;
end;
{*****************************************************************************
This function will be used to return a list of selected components on the
current designer.
#Name TDevFrameWorkRecordViewModule.GetSelectedComponents
#author Devia - Stefaan Lesage
#param None
#return None
#Exception None
#See None
******************************************************************************}
function TDevFrameWorkRecordViewModule.GetSelectedComponents: IDesignerSelections;
begin
Result := TDesignerSelections.Create;
Designer.GetSelections( Result );
end;
function TDevFrameWorkRecordViewModule.GetSelectedControl: TControl;
var
lcv : Integer;
begin
Result := Nil;
if ( Assigned( SelectedComponents ) ) then
begin
if ( SelectedComponents.Count <> 0 ) then
begin
for lcv := 0 to Pred( SelectedComponents.Count ) do
begin
if ( SelectedComponents.Items[ lcv ] is TControl ) then
begin
Result := TControl( SelectedComponents.Items[ lcv ] );
Break;
end;
end;
end;
end;
end;
function TDevFrameWorkRecordViewModule.GetVerb(Index: Integer): string;
begin
Case Index of
0 : Result := 'Dev.AddDataAwareComponents';
end;
end;
function TDevFrameWorkRecordViewModule.GetVerbCount: Integer;
begin
Result := 1;
end;
{*****************************************************************************
This function will determine the length of the Longest field's caption.
#Name TDevFrameWorkRecordViewModule.MaxFieldCaptionLength
#author Devia - Stefaan Lesage
#param None
#return Returns the length of the longest field's catpion.
#Exception None
#See None
******************************************************************************}
function TDevFrameWorkRecordViewModule.MaxFieldCaptionLength(
aFields: TFields): Integer;
var
aMaxCaptionWidth : Integer;
aCanvas : TCanvas;
lcv : Integer;
aCaption : String;
begin
aMaxCaptionWidth := 0;
{ First Determine how long the largest caption will be }
aCanvas := TDevFrameWorkRecordView( Root ).Canvas;
{ Loop over each field to dertermin which caption is the longest one }
for lcv := 0 to Pred( aFields.Count ) do
begin
if ( aFields[ lcv ].DisplayLabel <> '' ) then
begin
aCaption := aFields[ lcv ].DisplayLabel;
end
else
begin
aCaption := aFields[ lcv ].FieldName;
end;
if ( aCanvas.TextWidth( aCaption ) >
aMaxCaptionWidth ) then
begin
aMaxCaptionWidth := aCanvas.TextWidth( aCaption );
end;
end;
{ Return the Length of the Longest Caption }
Result := aMaxCaptionWidth;
end;
procedure TDevFrameWorkRecordViewModule.DevAddDBAwareComponentsWizard( aParent : TControl );
var
aRecordView : IDevFrameWorkRecordView;
aDataSource : TDataSource;
begin
{$IFDEF CODESITE}
csFWRecordView.EnterMethod( Self, 'DevAddDBAwareComponentsWizard' );
{$ENDIF}
if ( Supports( Root, IDevFrameWorkRecordView, aRecordView ) ) then
begin
{$IFDEF CODESITE}
csFWRecordView.SendMsg( csmInfo, 'Root supports I®FrameWorkRecordView' );
{$ENDIF}
aDataSource := TDataSource( Designer.GetComponent( 'srcMain' ) );
if ( Assigned( aDataSource ) ) and
( Assigned( aDataSource.DataSet ) ) then
begin
{$IFDEF CODESITE}
csFWRecordView.SendMsg( csmInfo, 'aRecordView.DataSource Assigned' );
csFWRecordView.SendMsg( csmInfo, 'aRecordView.DataSource.DataSet Assigned' );
{$ENDIF}
CreateDBAwareComponents( aParent, aDataSource, aDataSource.DataSet.Fields, aDataSource.DataSet.FieldDefs );
end;
end;
{$IFDEF CODESITE}
csFWRecordView.ExitMethod( Self, 'DevAddDBAwareComponentsWizard' );
{$ENDIF}
end;
Of course this won't compile for you. It is something I wrote for a development framework in Delphi 7 a few years ago. It should give you an idea though on how you could actually do it.
Regards,
Stefaan
Related
I need to make the TCheckColumn from the FMX.StringGrid to work from an integer value but I don't know how.
My code reads from a JSON request and translates it to a stringgrid. In the database the "boolean" field is stored as integer, so 0 for false and 1 for true.
This is the code that reads from the request:
procedure TDM.CarregaDados(aTable: string; aGrid: TStringGrid);
begin
TThread.CreateAnonymousThread(
procedure
var
str: string;
begin
aGrid.RowCount := 0;
REST.Response := nil;
REST.Resource := aTable;
REST.Method := rmGET;
REST.Params.ClearAndResetID;
REST.Execute;
RESTDSA.Response := REST.Response;
RESTDSA.DataSet := RESTDS;
RESTDSA.Active := true;
TThread.Synchronize(nil,
procedure
var
I: Integer;
begin
aGrid.BeginUpdate;
while not RESTDS.Eof do
begin
aGrid.RowCount := aGrid.RowCount + 1;
for I := 0 to RESTDS.FieldCount - 1 do
aGrid.Cells[I, aGrid.RowCount - 1] := RESTDS.Fields.Fields
[I].AsString;
RESTDS.Next;
end;
aGrid.EndUpdate;
end);
REST.ClearBody;
REST.Params.ClearAndResetID;
end).Start;
end;
REST is the TRESTRequest component,
RESTDS is the TFDMemTable,
RESTDSA is the TRESTRequestDataSetAdapter component,
aGrid is a TStringGrid and
aTable is the endpoint resource.
What I wanna know is how I can tweak this code to make it work with TCheckColumn in my grid. Yes, Of course I have a TIntegerColumn, a TStringColumn and a TCheckColumn previously added to the grid.
This is an example JSON response:
[
{
"ID" : 1,
"Descr" : "test",
"ischeck" : 0
},
{
"ID" : 2,
"Descr" : "test",
"ischeck" : 1
}
]
Well I know It's late, but I am a newbie here, and it's the first time I use FMX.TStringGrid without Livebindings.
I found a solution to this problem, with my own data
procedure TCsv4Presta.StringGrid1CellClick(const Column: TColumn;
const Row: Integer);
begin
case Column.Index of
0 : begin // my checkboxcolumn
StringGrid1.Cells[0,Row]:= BooltoStr(Not StrToBool(StringGrid1.Cells[0,Row]),true);
Column.UpdateCell(Row); // important to refresh checkbox
end;
end;
end;
just a problem with this onclick, you have to manage click in the cell but not on the checkbox
So I can suggest you a code like
while not RESTDS.Eof do
begin
aGrid.RowCount := aGrid.RowCount + 1;
for I := 0 to RESTDS.FieldCount - 1 do
begin
if aGrid.Columns[I] is TCheckBoxColumn then
begin
aGrid.Cells[I, aGrid.RowCount - 1] := BooltoStr(RESTDS.Fields.Fields
[I].AsString='1',true) ;
// Column.UpdateCell(Row);
end
else aGrid.Cells[I, aGrid.RowCount - 1] := RESTDS.Fields.Fields
[I].AsString;
end;
RESTDS.Next;
end;
I use memtables to wire enumerated type with comboboxes using LiveBinding.
However I have a lot of them and they way I am doing is way too bad (copy/paste)
For example, I have the following enumeration:
TEnumResourceType = (trtApp, trtTab, trtSection, trtField, trtCommand, trtOther);
and for that I created a function to give the string equivalent:
function EnumResourceTypeToStr(AEnum: TNaharEnumResourceType): string;
begin
case AEnum of
trtApp : result := 'Aplicação';
trtTab : result := 'Pagina (Tab)';
trtSection : result := 'Secção';
trtField : result := 'Campo';
trtCommand : result := 'Comando';
trtOther : result := 'Outro';
end;
end;
In a datamodule I place my memtable and I need to populate it, I am using the AFTEROPEN event of the table with the following code:
procedure TDMGlobalSystem.vtResourceTypeAfterOpen(DataSet: TDataSet);
var
enum : TEnumResourceType;
begin
inherited;
for enum := Low(TEnumResourceType) to High(TEnumResourceType) do
DataSet.InsertRecord([EnumResourceTypeToStr(enum), Ord(enum)]);
end;
All that works, however I need to do that for each new enumaration and I have dozens. Eventually I will need to change my current memtable to other and that is an added concern to automate the process. The current memtable sometimes does not work on Android.
I am looking in a way to automate this process, or using generics, or whatever, that in the DataModule I only need something like: PopulateEnum(Table, Enum);
The best solution would be creating a component inherited from this memtable and somehow define what is the enum required and all the magic happens (including the selection of the enumtostr)
Here is a generic wrapper for enums to get an array of integer,string pair representing the ordinal value and the name for the enums.
A little test
program so_24955704;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
EnumValueStore in 'EnumValueStore.pas';
type
TEnumResourceType = ( trtApp, trtTab, trtSection, trtField, trtCommand, trtOther );
procedure PrintEnumValueStore( AEnumValueStore : TEnumValueStore );
var
LEnumValuePair : TEnumValuePair;
begin
for LEnumValuePair in AEnumValueStore.GetKeyValues do
begin
Writeln( LEnumValuePair.Key, '-', LEnumValuePair.Value );
end;
end;
procedure TestEnum;
var
LEnumValueStore : TEnumValueStore<TEnumResourceType>;
begin
LEnumValueStore := TEnumValueStore<TEnumResourceType>.Create;
try
// print default names
PrintEnumValueStore( LEnumValueStore );
WriteLn;
// set the custom names
LEnumValueStore.SetValue( trtApp, 'Aplicação' );
LEnumValueStore.SetValue( trtTab, 'Pagina (Tab)' );
LEnumValueStore.SetValue( trtSection, 'Secção' );
LEnumValueStore.SetValue( trtField, 'Campo' );
LEnumValueStore.SetValue( trtCommand, 'Comando' );
LEnumValueStore.SetValue( trtOther, 'Outro' );
// print the default values
PrintEnumValueStore( LEnumValueStore );
finally
LEnumValueStore.Free;
end;
end;
begin
try
TestEnum;
except
on E : Exception do
Writeln( E.ClassName, ': ', E.Message );
end;
ReadLn;
end.
will produce the following output
0-App
1-Tab
2-Section
3-Field
4-Command
5-Other
0-Aplicação
1-Pagina (Tab)
2-Secção
3-Campo
4-Comando
5-Outro
and here is the unit that will do the work
unit EnumValueStore;
interface
uses
System.Generics.Collections;
type
TEnumValuePair = TPair<Integer, string>;
TEnumValueStore = class abstract
public
function GetKeyValues : TArray<TEnumValuePair>; virtual; abstract;
end;
TEnumValueStore<TEnumKey> = class( TEnumValueStore )
private
FValueDict : TDictionary<TEnumKey, string>;
public
constructor Create;
destructor Destroy; override;
procedure SetValue( AKey : TEnumKey; const AValue : string );
function GetKeyValues : TArray<TEnumValuePair>; override;
end;
implementation
uses
SimpleGenericEnum;
{ TEnumValueStore<TEnumKey> }
constructor TEnumValueStore<TEnumKey>.Create;
begin
inherited Create;
FValueDict := TDictionary<TEnumKey, string>.Create;
end;
destructor TEnumValueStore<TEnumKey>.Destroy;
begin
FValueDict.Free;
inherited;
end;
function TEnumValueStore<TEnumKey>.GetKeyValues : TArray<TEnumValuePair>;
var
LEnum : TEnum<TEnumKey>;
LMin, LMax : Integer;
LCount : Integer;
LIdx : Integer;
LStr : string;
begin
LMin := LEnum.Ord( LEnum.Low );
LMax := LEnum.Ord( LEnum.High );
LCount := LMax - LMin + 1;
SetLength( Result, LCount );
LCount := 0;
for LIdx := LMin to LMax do
begin
LEnum := LIdx;
if FValueDict.ContainsKey( LEnum )
then
LStr := FValueDict[LEnum]
else
LStr := LEnum;
Result[LCount] := TEnumValuePair.Create( LEnum, LStr );
Inc( LCount );
end;
end;
procedure TEnumValueStore<TEnumKey>.SetValue( AKey : TEnumKey; const AValue : string );
begin
FValueDict.AddOrSetValue( AKey, AValue );
end;
end.
I use the unit SimpleGenericEnum but there is a small bug inside you need to correct
class function TEnum<T>.High: T;
begin
// original code
// Result := Cast(_TypeData.MaxValue);
Result := Cast(GetTypeData.MaxValue);
end;
class function TEnum<T>.Low: T;
begin
// original code
// Result := Cast(_TypeData.MinValue);
Result := Cast(GetTypeData.MinValue);
end;
I would have said you have two easier choices here
Your could replace EnumResourceTypeToStr(enum) with GetEnumName(TypeInfo(TEnumResourceType), ord(enum)) or some variation on it. This has the disadvantage that it simply returns the enum as it appears in your program.
Alternatively add a constant EnumNames: array [TEnumResourceType] of string = ('.... etc. populated with your list of strings. These can then be accessed as EnumNames[enum]. This allows you arbitrary strings and the compiler will remind you to add additional entries if you extend the enumeration.
I am using a Tabbed Listbox component that was written by Fredric Rylander back in 1999 and it has been serving me well since then. :) Can't seem to find him anymore.
I now have an application that needs both Tabbed Data and alternating colored lines in the Listbox.
I can include the Component here for perusal if desired.
I tried coloring the lines from here
http://delphi.about.com/cs/adptips2002/a/bltip0602_4.htm
But then it eats the Tabs, but I do get the alternating colored lines.
Can someone please show me how to incorporate the two.
Thanks
Here's the Component
unit myListBoxTabbed;
{
Copyright © 1999 Fredric Rylander
You can easily add a header control to this list box: drop a header
control onto the form (it's default align property is set to alTop, if
it's not--set it); then set the myTabbedListBox's aligned property
to alClient; now, add the following two events and their code.
1) HeaderControl's OnSectionResize event:
var
i, last: integer;
begin
last := 0;
for i:=0 to HeaderControl1.Sections.Count-1 do begin
last := last + HeaderControl1.Sections[i].Width;
myTabbedListBox1.TabStops[i] := last;
end;
end;
2) Main form's OnCreate event:
var
i, last: integer;
begin
last := 0;
for i:=0 to HeaderControl1.Sections.Count-1 do begin
last := last + HeaderControl1.Sections[i].Width;
myTabbedListBox1.TabStops[i] := last;
end;
for i:=HeaderControl1.Sections.Count to MaxNumSections do
myTabbedListBox1.TabStops[i] := 2000;
end;
To get tab characters into the list box items either use the
string list property editor in the Delphi GUI and press
Ctrl + Tab or add tab characters (#9) in strings as so:
myTabbedListBox1.Items.Add( Edit1.Text + #9 + Edit2.Text );
I hope you find this tutorial helpful! :^)
(!) This is not a retail product, it's a tutorial and don't claim to
meet a potential user's demands.
If you find anything that seems odd (or incorrect even) don't hesitate to
write me a line. You can communicate with me at fredric#rylander.nu.
The source is available for you to use, abuse, modify and/or improve.
Happy trails!
/ Fredric
___________________________________F_r_e_d_r_i_c__R_y_l_a_n_d_e_r__
fredric#rylander.nu : www.rylander.nu : 6429296#pager.mirabilis.com
"power to the source sharing community"
}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TTabsArray = array[0..9] of integer;
type
TmyTabbedListBox = class( TListBox )
private
{ Private declarations }
fTabStops: TTabsArray;
function GetTabStops( iIndex: integer ): integer;
procedure SetTabStops( iIndex, iValue: integer);
function GetTabsString: string;
procedure SetTabsString( const sValue: string );
protected
{ Protected declarations }
procedure UpdateTabStops;
public
{ Public declarations }
procedure CreateParams( var cParams: TCreateParams ); override;
procedure CreateWnd; override;
property TabStops[ iIndex: integer ]: integer
read GetTabStops write SetTabStops;
published
{ Published declarations }
property TabsString: string
read GetTabsString write SetTabsString;
end;
procedure Register;
resourcestring
STR_ALPHA_UPPERLOWER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
CHAR_SEMICOLON = ';';
implementation
procedure Register;
begin
RegisterComponents('Additional', [TmyTabbedListBox]);
end;
{ myTabbedListBox }
procedure TmyTabbedListBox.CreateParams(var cParams: TCreateParams);
begin
inherited CreateParams( cParams );
// add the window style LBS_USETABSTOPS to accept tabs
cParams.Style := cParams.Style or LBS_USETABSTOPS;
end;
procedure TmyTabbedListBox.CreateWnd;
var
i: integer;
begin
inherited CreateWnd;
// set all the tabs into the box
for i := Low( fTabStops ) to High( fTabStops ) do
fTabStops[i] := i * 100;
// show the real tab positions
UpdateTabStops;
end;
function TmyTabbedListBox.GetTabsString: string;
var
sBuffer: string;
i: integer;
begin
// init var
sBuffer := SysUtils.EmptyStr;
// set all tabstops to the string (separated by ';'-char)
for i := Low( fTabStops ) to High( fTabStops ) do
sBuffer := sBuffer + IntToStr( fTabStops[i] ) + CHAR_SEMICOLON;
// and here we have the results
Result := sBuffer;
end;
function TmyTabbedListBox.GetTabStops( iIndex: integer ): integer;
begin
// nothing funny here
Result := fTabStops[iIndex];
end;
procedure TmyTabbedListBox.SetTabsString( const sValue: string );
var
sBuffer: string;
i, len: integer;
begin
// copy value into buffer
sBuffer := sValue;
// set the tabstops as specified
for i := Low( fTabStops ) to High( fTabStops ) do begin
len := Pos( sBuffer, CHAR_SEMICOLON );
fTabStops[i] := StrToIntDef( Copy( sBuffer, 1, len ), 0 );
Delete( sBuffer, 1, len );
end;
// show/redraw the results
UpdateTabStops;
Invalidate;
end;
procedure TmyTabbedListBox.SetTabStops( iIndex, iValue: integer );
begin
// do we really need to update?
if fTabStops[iIndex] <> iValue then begin
// oki, let's then
fTabStops[iIndex] := iValue;
// show/redraw the results
UpdateTabStops;
Invalidate;
end;
end;
procedure TmyTabbedListBox.UpdateTabStops;
var
i, iHUnits: integer;
arrConvertedTabs: TTabsArray;
begin
// convert dialog box units to pixels.
// dialog box unit = average character width/height div 4/8
// determine the horizontal dialog box units used by the
// list box (which depend on its current font)
Canvas.Font := Font;
iHUnits := Canvas.TextWidth( STR_ALPHA_UPPERLOWER ) div 52;
// convert the array of tab values
for i := Low( arrConvertedTabs ) to High( arrConvertedTabs ) do
arrConvertedTabs[i] := ( fTabStops[i] * 4 ) div iHUnits;
// activate the tabs stops in the list box,
// sending a Windows list box message
SendMessage( Handle, LB_SETTABSTOPS,
1 + High( arrConvertedTabs ) - Low( arrConvertedTabs ),
LongInt( #arrConvertedTabs ) );
end;
end.
Here's an example using a standard TListBox and it's OnDrawItem event, based on the code from the link you provided and tested in Delphi 2007. Note you need to set the ListBox.Style to lbOwnerDrawFixed. You can perhaps use this as a base for modifying the component (or just abandon it altogether).
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
LB: TListBox;
NewColor: TColor;
NewBrush: TBrush;
R: TRect;
Fmt: Cardinal;
ItemText: string;
begin
NewBrush := TBrush.Create;
LB := (Control as TListBox);
if (odSelected in State) then
begin
NewColor := LB.Canvas.Brush.Color;
end
else
begin
if not Odd(Index) then
NewColor := clSilver
else
NewColor := clYellow;
end;
NewBrush.Style := bsSolid;
NewBrush.Color := NewColor;
// This is the ListBox.Canvas brush itself, not to be
// confused with the NewBrush we've created above
LB.Canvas.Brush.Style := bsClear;
R := Rect;
ItemText := LB.Items[Index];
Fmt := DT_EXPANDTABS or DT_CALCRECT or DT_NOCLIP;
DrawText(LB.Canvas.Handle, PChar(ItemText), Length(ItemText),
R, Fmt);
// Note we need to FillRect on the original Rect and not
// the one we're using in the call to DrawText
Windows.FillRect(LB.Canvas.Handle, Rect, NewBrush.Handle) ;
DrawText(LB.Canvas.Handle, PChar(ItemText), Length(ItemText),
R, DT_EXPANDTABS);
NewBrush.Free;
end;
Here's the output of the above code:
Below, I inserted a code written by Ray Konopka (part of the Coderage presentation). I am planning to use it, however, I am not sure how to clean (on the fly) multiple objects.
All my attempts were unsucesfull and rendered memory leak.
Any thoughts are appreciated.
Thanks,
program stringlistDictionary;
{$APPTYPE CONSOLE}
uses
Classes,
SysUtils;
type
TPlayer = class
public
Name: string;
Position: string;
Hits: Integer;
AtBats: Integer;
constructor Create( Name, Position: string );
end;
constructor TPlayer.Create( Name, Position: string );
begin
inherited Create;
Self.Name := Name;
Self.Position := Position;
Hits := 0;
AtBats := 0;
end;
var
Team: TStringList;
Player, NewPlayer: TPlayer;
I: Integer;
function FindPlayer( const Name: string ): TPlayer;
var
Idx: Integer;
begin
Result := nil;
if Team.Find( Name, Idx ) then
Result := TPlayer( Team.Objects[ Idx ] );
end;
begin {== Main ==}
Writeln( 'StringList Dictionary' );
Writeln( '---------------------' );
Writeln;
Team := TStringList.Create;
try
NewPlayer := TPlayer.Create( 'Aramis Ramerez', 'Third Base' );
NewPlayer.Hits := 120;
NewPlayer.AtBats := 350;
Team.AddObject( NewPlayer.Name, NewPlayer );
NewPlayer := TPlayer.Create( 'Derrick Lee', 'First Base' );
NewPlayer.Hits := 143;
NewPlayer.AtBats := 329;
Team.AddObject( NewPlayer.Name, NewPlayer );
NewPlayer := TPlayer.Create( 'Ryan Theriot', 'Short Stop' );
NewPlayer.Hits := 87;
NewPlayer.AtBats := 203;
Team.AddObject( NewPlayer.Name, NewPlayer );
Player := FindPlayer( 'Derrick Lee' );
if Player <> nil then
Writeln( 'Player Found: ', Player.Name, ', ', Player.Position )
else
Writeln( 'Player not found.' );
Writeln;
Writeln( 'Active Roster' );
Writeln( '-------------' );
for I := 0 to Team.Count - 1 do
Writeln( TPlayer( Team.Objects[ I ] ).Name, #9,
TPlayer( Team.Objects[ I ] ).Position );
Readln;
finally
//!! Need to free the players.
Team.Free;
end;
end.
With Delphi 2009, the TStringList constructor has an optional boolean parameter "OwnsObjects". If you set that to true, the objects are freed automatically.
Else you can do the following:
for i := Team.Count-1 downto 0 do begin
Team.Objects.Free;
end;
Team.Free;
And by the way, public fields are discouraged. You beter use properties so you can control what access is possible to the fields. And you can add setter functions to validate the input.
type
TPlayer = class
private
FName : string;
FPosition : string;
FHits : Integer;
FAtBats : Integer;
public
constructor Create(const AName, APosition: string );
property Name: string read FName;
property Position: string read FPosition;
property Hits: Integer read FHits write FHits;
property AtBats: Integer read FAtBats write FAtBats;
end;
Kinda obvious, but still - you don't have to write 'for ... Free' code every time you want to clear TStringList objects. You can put it into a global function.
procedure FreeObjects(sl: TStringList);
var
i: integer;
begin
for i := 0 to sl.Count - 1 do
sl.Objects[i].Free;
end;
FreeObjects(Team);
Or you can put it into a TStringList helper.
TStringListHelper = class helper for TStringList
public
procedure FreeObjects;
end;
procedure TStringListHelper.FreeObjects;
var
i: integer;
begin
for i := 0 to Count - 1 do
Objects[i].Free;
end;
Team.FreeObjects;
just a clarification about gamecat answer: I don't know about delphi 2009 but usually the Objects property need an index, and you don't really need a reverse cycle, so:
for i := 0 to Team.Count-1 do
Team.Objects[i].Free;
Team.Free;
or:
while Team.Count > 0 do
begin
Team.Objects[0].Free;
Team.Delete(0);
end;
Team.Free;
Using D7, I can just subclass TStingList
This adds an ActionClientItem at runtime from a stringList:
var
ActionClient: TActionClient;
ChildItem: TActionClientItem;
if FileExists( ARecentFilesFilename ) then
begin
ARecentFilesList.LoadFromFile( ARecentFilesFilename );
// remove any duplicates
RemoveDuplicates( ARecentFilesList );
for i := 0 to ARecentFilesList.Count - 1 do
begin
Ribbon1.AddRecentItem( ARecentFilesList.Strings[ i ] );
ActionClient := RibbonGroup1.ActionControls[ 1 ].ActionClient;
ChildItem := ActionClient.Items.Add;
ChildItem.Tag := i;
ChildItem.Action := ActionOpenFileFromButton1;
ChildItem.Caption := ARecentFilesList.Strings[ i ];
end;
end;
This attempts to get the filename of the selected ActionClientItem but it fails.
procedure TMainForm.ActionOpenFileFromButton1Execute( Sender: TObject );
var
ActionClient: TActionClient;
ChildItem: TActionClientItem;
AFilename: string;
AIndex: integer;
begin
ActionClient := RibbonGroup1.ActionControls[ 1 ].ActionClient;
AIndex := ActionClient.Index;
ChildItem := ActionClient.Items.ActionClients[ AIndex ];
AFilename := ChildItem.Caption;
OpenZipFileFromChildButton( AFilename );
end;
What am I doing wrong?
Is there a different way do do this?
You can use the Sender to get access to the filename, but it's a TAction, so you need to have one action per recent file. Add them to your ActionManager and also keep a reference to them in a list.
edit
If you don't have a TActionManager on your form, drop one on there and associate it with the ribbon. Then, create say 10 actions, calling them RecentFileAction1, RecentFileAction2, etc. Then, in the form's OnCreate event handler, add them to your FRecentFileActions list:
TMainForm = class (TForm)
//...
private
FRecentFileActions: TList<TAction>;
//...
end;
procedure TMainForm.FormCreate(ASender: TOject);
begin
FRecentFileActions := TList<TAction>.Create;
FRecentFileActions.Add(RecentFileAction1);
FRecentFileActions.Add(RecentFileAction2);
FRecentFileActions.Add(RecentFileAction3);
// etc
LoadRecentFilenames;
RefreshActions;
end;
/edit
Then, change the caption on each action to the filename of the file.
procedure TMainForm.RefreshActions;
var
i: integer;
begin
for i := 0 to FRecentFileList.Count - 1 do
begin
if i < FRecentFileActions.Count then
FRecentFileActions[i].Caption := FRecentFileList[i];
end;
end;
So, in the end, your event handler could look like this:
procedure TMainForm.ActionOpenFileFromButton1Execute( Sender: TObject );
var
LAction: TAction;
begin
LAction := Sender as TAction;
OpenZipFileFromChildButton(LAction.Caption);
end;
N#