I want to implement a sortable DBgrid (that sorts its rows when clicked on column title). I managed to make it sortable in an ascending order but I can't do it in a descending order. Here are my design settings:
Query1.DatabaseName:='Test';
DataSetProvider1.DataSet:=Query1;
ClientDataSet1.ProviderName:=DataSetProvider1;
DataSource1.DataSet:=ClientDataSet1;
DBGrid1.DatSource:=DataSource1;
And here are fragments of my code:
procedure TForm2.FormShow(Sender: TObject);
begin
Query1.Open;
ClientDataSet1.Data:=DataSetProvider1.Data;
ClientDataSet1.AddIndex('objnameDESC','objname',[ixDescending]);
ClientDataSet1.AddIndex('SUM(cd.worktime)DESC','SUM(cd.worktime)',[ixDescending]);
end;
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
case Column.Index of
0: if ClientDataSet1.IndexFieldNames='objname' then
ClientDataSet1.IndexFieldNames:='objnameDESC'
else
ClientDataSet1.IndexFieldNames:='objname';
1: if ClientDataSet1.IndexFieldNames='SUM(cd.worktime)' then
ClientDataSet1.IndexFieldNames:='SUM(cd.worktime)DESC'
else
ClientDataSet1.IndexFieldNames:='SUM(cd.worktime)';
end;
end;
When I click on a column title for the first time, sorting is done in an ascending order - so up to here everything is OK. When I click for the second time I expect sorting in a descending order to be done but instead I get the message:
Project ... raised Exception class EDatabaseError with message
'ClientDataSet1: Field 'objnameDESC' not found'.
Any ideas about what I am doing wrong?
As you are already using TClientDataSet you might make use of a component I made for exactly that purpose. Create an instance, set its Grid property and it will automatically connect to the OnTitleClick event.
type
TDBGridSorter = class(TComponent)
strict private
FSortColumn: TColumn;
FGrid: TDBGrid;
procedure CreateIndex(const FieldName: string; Descending: Boolean);
function GetDataSet: TClientDataSet;
function MakeIndexName(const FieldName: string; Descending: Boolean): string;
procedure SetSortColumn(const Value: TColumn);
procedure SortByField(const FieldName: string; out Descending: Boolean);
private
procedure SetGrid(const Value: TDBGrid);
strict protected
procedure GridTitleClick(Column: TColumn);
property DataSet: TClientDataSet read GetDataSet;
public
property Grid: TDBGrid read FGrid write SetGrid;
property SortColumn: TColumn read FSortColumn write SetSortColumn;
end;
procedure TDBGridSorter.CreateIndex(const FieldName: string; Descending: Boolean);
var
cds: TClientDataSet;
indexDef: TIndexDef;
indexName: string;
begin
cds := DataSet;
if cds <> nil then begin
indexName := MakeIndexName(FieldName, Descending);
if cds.IndexDefs.IndexOf(indexName) < 0 then begin
indexDef := cds.IndexDefs.AddIndexDef;
indexDef.Name := indexName;
indexDef.Fields := FieldName;
indexDef.CaseInsFields := FieldName;
if Descending then
indexDef.DescFields := FieldName;
end;
end;
end;
function TDBGridSorter.GetDataSet: TClientDataSet;
begin
if (Grid <> nil) and (Grid.DataSource <> nil) and (Grid.DataSource.DataSet is TClientDataSet) then
Result := TClientDataSet(Grid.DataSource.DataSet)
else
Result := nil;
end;
procedure TDBGridSorter.GridTitleClick(Column: TColumn);
begin
SortColumn := Column;
end;
function TDBGridSorter.MakeIndexName(const FieldName: string; Descending: Boolean): string;
const
cAscDesc: array[Boolean] of string = ('_ASC', '_DESC');
begin
Result := FieldName + cAscDesc[Descending];
end;
procedure TDBGridSorter.SetGrid(const Value: TDBGrid);
begin
if FGrid <> Value then begin
if FGrid <> nil then begin
FGrid.OnTitleClick := nil;
FGrid.RemoveFreeNotification(Self);
end;
FGrid := Value;
if FGrid <> nil then begin
FGrid.FreeNotification(Self);
FGrid.OnTitleClick := GridTitleClick;
end;
end;
end;
procedure TDBGridSorter.SetSortColumn(const Value: TColumn);
const
cOrder: array[Boolean] of string = ('˄', '˅');
var
descending: Boolean;
S: string;
begin
if FSortColumn <> nil then begin
S := FSortColumn.Title.Caption;
if StartsStr(cOrder[false], S) or StartsStr(cOrder[true], S) then begin
Delete(S, 1, 2);
FSortColumn.Title.Caption := S;
end;
end;
FSortColumn := Value;
if FSortColumn <> nil then begin
SortByField(FSortColumn.FieldName, descending);
FSortColumn.Title.Caption := Format('%s %s', [cOrder[descending], FSortColumn.Title.Caption]);
end;
end;
procedure TDBGridSorter.SortByField(const FieldName: string; out Descending:
Boolean);
var
cds: TClientDataSet;
curIndex: TIndexDef;
N: Integer;
begin
cds := DataSet;
if cds <> nil then begin
descending := false;
N := cds.IndexDefs.IndexOf(cds.IndexName);
if N >= 0 then begin
curIndex := cds.IndexDefs[N];
if SameText(FieldName, curIndex.Fields) then
descending := not (ixDescending in curIndex.Options)
end;
{ make sure the index exists }
CreateIndex(FieldName, descending);
cds.IndexName := MakeIndexName(FieldName, descending);
end;
end;
Wrong assignment
Apart from the fact that an incorrect assignment is made, a switch back to "ascending" is not possible.
For 2 Colums you need 4 Indexes.
Assuming 'objname' and 'SUM(cd.worktime)' are Fields.
procedure TForm2.FormShow(Sender: TObject);
....
ClientDataSet1.AddIndex('col0_asc','objname',[]);
ClientDataSet1.AddIndex('col0_desc','objname',[ixDescending]);
ClientDataSet1.AddIndex('col1_asc','SUM(cd.worktime)',[]);
ClientDataSet1.AddIndex('col1_desc','SUM(cd.worktime)',[ixDescending]);
....
Use ClientDataSet1.IndexName
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
case Column.Index of
0: if ClientDataSet1.IndexName='col0_asc' then
ClientDataSet1.IndexName:='col0_desc'
else
ClientDataSet1.IndexName:='col0_asc';
1: if ClientDataSet1.IndexName='col1_asc' then
ClientDataSet1.IndexName:='col1_desc'
else
ClientDataSet1.IndexName:='col1_asc';
end;
....
Or shorter
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
if ClientDataSet1.IndexName='col'+IntToStr(Column.Index)+'_asc' then
ClientDataSet1.IndexName:='col'+IntToStr(Column.Index)+'_desc'
else
ClientDataSet1.IndexName:='col'+IntToStr(Column.Index)+'_asc';
....
But it is better to test the number of columns that are active (AddIndex = done).
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
if Column.Index < 2 then begin
if ClientDataSet1.IndexName='col'+IntToStr(Column.Index)+'_asc' then
ClientDataSet1.IndexName:='col'+IntToStr(Column.Index)+'_desc'
else
ClientDataSet1.IndexName:='col'+IntToStr(Column.Index)+'_asc';
end;
....
You should be setting the IndexName and not IndexFieldNames. IndexFieldNames accepts field names and creates an index on the fly.
procedure TForm2.DBGrid1TitleClick(Column: TColumn);
begin
case Column.Index of
0: if ClientDataSet1.IndexFieldNames='objname' then
ClientDataSet1.IndexName:='objnameDESC'
else
ClientDataSet1.IndexFieldNames:='objname';
1: if ClientDataSet1.IndexFieldNames='SUM(cd.worktime)' then
ClientDataSet1.IndexFieldNames:='SUM(cd.worktime) DESC'
else
ClientDataSet1.IndexFieldNames:='SUM(cd.worktime)';
end;
end;
Many of my programs need this, so I wrote a general procedure which builds two indices for each field in the dataset
Procedure BuildIndices (cds: TClientDataSet);
var
i, j: integer;
alist: tstrings;
begin
with cds do
begin
open;
for i:= 0 to FieldCount - 1 do
if fields[i].fieldkind <> fkCalculated then
begin
j:= i * 2;
addindex ('idx' + inttostr (j), fieldlist.strings[i], [], '', '', 0);
addindex ('idx' + inttostr (j+1), fieldlist.strings[i], [ixDescending], '', '',0);
end;
alist:= tstringlist.create;
getindexnames (alist);
alist.free;
close;
end;
end;
At this stage, I have indices idx0 and idx1 for the first field, idx2 and idx3 for the second field, etc.
Then, in the form which displays the dbgrid (here the active query is called qShowFees)
procedure TShowFees.DBGrid1TitleClick(Column: TColumn);
var
n, ex: word;
begin
n:= column.Index;
try
dbGrid1.columns[prevcol].title.font.color:= clNavy
except
end;
dbGrid1.columns[n].title.font.color:= clRed;
prevcol:= n;
directions[n]:= not directions[n];
ex:= n * 2;
if directions[n] then inc (ex);
with qShowFees do
try
disablecontrols;
close;
indexname:= 'idx' + inttostr (ex);
open
finally
enablecontrols
end;
end;
'Directions' is a form array of booleans which 'remembers' which way each column is currently sorted (ascending or descending) so clicking the dbgrid's title bar a second time will cause the grid to be sorted in the opposing manner to which it was sorted before. 'Prevcol' is a form variable which stores the currently selected column; this is saved between invocations, so the next time the user opens the form, it is sorted in the same way as she left it previously.
Related
I store controls 'visible' and 'enabled' property in DB table. Depending on user's role I make some controls not visible/enabled.
fields of db Table "Controls": id, role_id, form (varchar), comp_name(varchar), visible (boolean), enable (boolean)
query qControls: select * from controls where form=:form
calling of this procedure from OnShow of main form:
application.CreateForm(TForm1, Form1);
FORM := 'Form1';
Form1.showModal;
Called procedure:
procedure RightsOnControls();
var i:integer;
begin
fMain.qControls.Close;
fMain.qControls.Params[0].AsString:= FORM; //FORM is global variable: FORM:='Form1'
fMain.qControls.Open;
if fMain.qControls.RecordCount>0 then begin
while not fMain.Controls.Eof do begin
for I := 0 to form1.ControlCount - 1 do
if uppercase(form1.Controls[i].Name)= uppercase(fMain.qControlsComp_name.AsString) then
begin
form1.Controls[i].Visible:=fmain.qControlsVisible.AsBoolean;
form1.Controls[i].Enabled:=fmain.qControlsEnable.AsBoolean;
end;
fMain.qControls.next;
end;
end;
end;
My questions are:
how make procedure as general event handler,not for only Form1?
It finds only controls located on form, not controls located on the panel/Page control (tabsheet). How change it?
Call this procedure with the form to handle (f.i. form1) and the query (fMain.qControls):
procedure RightsOnControls(AForm: TForm; AQuery: TFDQuery);
function FindChildControl(Parent: TWinControl; const ControlName: string): TControl;
var
I: Integer;
begin
for I := 0 to Parent.ControlCount - 1 do begin
Result := Parent.Controls[I];
if SameText(Result.Name, ControlName) then Exit;
if Result is TWinControl then begin
Result := FindChildControl(TWinControl(Result), ControlName);
if Result <> nil then Exit;
end;
end;
Result := nil;
end;
var
ctl: TControl;
begin
AQuery.Close;
AQuery.Params[0].AsString := AForm.Name;
AQuery.Open;
while not AQuery.Eof do begin
ctl := FindChildControl(AForm, AQuery.FieldByName('Comp_name').AsString);
if ctl <> nil then begin
ctl.Visible := AQuery.FieldByName('Visible').AsBoolean;
ctl.Enabled := AQuery.FieldByName('Enable').AsBoolean;
end;
AQuery.next;
end;
end;
In case you don't use FireDAC, change the query type to whatever is appropriate.
From the query below
Select FIELD1,FIELD2,FIELD3,FIELD4 FROM MyTable Order By FIELD1,FIELD2,FIELD3,FIELD4 Group By FIELD1,FIELD2,FIELD3,FIELD4
I have a recordset like this:
I need to show data in a treeview like this:
I'm stuck with the code below.
var
Node: TTreeNode;
RootLevelCount: Integer;
X: Integer;
CurrentTextField: String;
MyTreeNodeText: array [0..10] of String;
begin
RootLevelCount := 4;
while not dm1.Q1.Eof do
begin
for X := 0 to RootLevelCount do
begin
CurrentTextField:=dm1.Q1.Fields[x].AsString;
if CurrentTextField='' then CurrentTextField := 'Level '+IntToStr(x);
if MyTreeNodeText[x]<>CurrentTextField then
begin
MyTreeNodeText[X]:=CurrentTextField;
if x=0 then
begin
Node:=tree.Items.AddFirst(Node, CurrentTextField);
end else
begin
node:=tree.Items.AddChild(node.Parent, CurrentTextField);
end;
end else
begin
node.GetNext;
end;
end;
dm1.Q1.Next;
end;
The result I have is the following and it's not I want:
After a good lunch, my mind has reborn then I found the solution.
var
Node: TTreeNode;
RootLevelCount: Integer;
X,X1: Integer;
CurrentTextField: String;
MyTreeNodeText: array [0..10] of String;
MyTreeNode: array [0..10] of TTreeNode;
begin
RootLevelCount := 4; //Number of fields that you want to show in the treeview
while not dm1.Q1.Eof do
begin
ROW_ID:=dm1.Q1.FieldByName('ROW_ID').AsString;
for X := 0 to RootLevelCount-1 do
begin
CurrentTextField:=dm1.Q1.Fields[4+x].AsString;
if CurrentTextField='' then CurrentTextField := 'Level '+IntToStr(x);
if MyTreeNodeText[x]<>CurrentTextField then
begin
MyTreeNodeText[X]:=CurrentTextField;
for X1 := x+1 to RootLevelCount-1 do
MyTreeNodeText[x1]:='';
if x=0 then
begin
Node:=tree.Items.Add(nil, CurrentTextField);
TMyTreeNode(Node).Indice:=StrToInt(ROW_ID);
MyTreeNode[x]:=node;
end else
begin
node:=tree.Items.AddChild(MyTreeNode[x-1], CurrentTextField);
TMyTreeNode(Node).Indice:=StrToInt(ROW_ID);
MyTreeNode[x]:=node;
end;
end;
end;
MyTreeNodeText[RootLevelCount]:='';
dm1.Q1.Next;
end;
then the result is the following:
i have a problem if i getting my defined type object.
I need to get my variables-defined object from a ListBox.
My data types:
type
TObjectData = class
Id: Integer;
DataType: String;
end;
TProjektInfo = record
Id: Integer;
Nazev: String;
end;
TReportSelect = record
Count: Integer;
Zakazka_Id: Integer;
Singles: Array of TProjektInfo;
Multies: Array of TProjektInfo;
end;
My procedure for fill listbox:
procedure TReportMain.VykresyFillProjectsList();
var
I,Id: Integer;
Nazev: String;
ItemData: TObjectData;
begin
VykresyProjectsListSections.Items.BeginUpdate;
VykresyProjectsListSections.Items.Clear;
for I := Low(ReportSelect.Singles) to High(ReportSelect.Singles) do
begin
Id := ReportSelect.Singles[I].Id;
Nazev := ReportSelect.Singles[I].Nazev;
ItemData := TObjectData.Create;
ItemData.Id := Id;
ItemData.DataType := 'single';
VykresyProjectsListSections.Items.AddObject(Nazev, TObject(ItemData));
ItemData.Free;
end;
for I := Low(ReportSelect.Multies) to High(ReportSelect.Multies) do
begin
Id := ReportSelect.Multies[I].Id;
Nazev := ReportSelect.Multies[I].Nazev;
ItemData := TObjectData.Create;
ItemData.Id := Id;
ItemData.DataType := 'multi';
VykresyProjectsListSections.Items.AddObject(Nazev, TObject(ItemData));
ItemData.Free;
end;
VykresyProjectsListSections.Items.EndUpdate;
end;
My button event on click for getting my datatype object (this is wrong where is commented):
procedure TReportMain.BtnExportProjectsClick(Sender: TObject);
var
ItemData: TObjectData;
Nazev: String;
I: Integer;
begin
ItemData := TObjectData.Create;
for I := 0 to VykresyProjectsListSections.Count - 1 do
begin
if VykresyProjectsListSections.Checked[I] then
begin
ItemData := TObjectData(VykresyProjectsListSections.Items.Objects[I]); // <--- This is wrong, why ?
Nazev := VykresyProjectsListSections.Items.Strings[I];
showMessage(Format('Nazev: %s ID: %d Type: %s', [Nazev, ItemData.Id, ItemData.DataType]));
end;
end;
end;
What happens to you is probably an access violation.
The variable you're trying to access is undefined because you have already freed the object the variable is pointing to.
In the code above, the ItemData object is always freed after it's added to the list.
You have to write some code to free the object when the list is cleared or freed.
This can be done in the OnDestroy event of your form:
procedure TReportMain.FormDestroy(Sender: TObject);
var
i: Integer;
begin
for i := VykresyProjectsListSections.Items.Count-1 downto 0 do begin
VykresyProjectsListSections.Items.Objects[i].Free;
VykresyProjectsListSections.Delete(i);
end;
VykresyProjectsListSections.Free;//free the list if not owned by the application
end;
As a side note, you can test if a TCheckListBox element is checked like this:
var
i: Integer;
begin
for i := 0 to VykresyProjectsListSections.Items.Count-1 do begin
if VykresyProjectsListSections.State[i] = cbChecked then
//do your stuff
end;
end;
You are calling ItemData.Free after AddObject(). This is wrong, since the object will not be valid anymore.
This will cause the error when later accessing the object in the CheckListBox.
I have stringlist with comments (like Ini file section content):
;comment c
c=str1
;comment b
b=str2
;comment a
a=str3
Any ideas how to sort this list by names to:
;comment a
a=str3
;comment b
b=str2
;comment c
c=str1
Comment for pair should be linked with pair during sorting
One option would be to parse the TStringList content into a second list that separates and groups the name, value, and comment strings together, then sort that list on the names as needed, then repopulate the TStringList with the sorted groups. For example:
uses
...
System.Classes,
System.SysUtils,
System.Generics.Defaults,
System.Generics.Collections,
System.StrUtils,
System.Types;
type
ItemInfo = record
LeadingText,
Name,
Value: string;
end;
ItemInfoComparer = class(TComparer<ItemInfo>)
public
function Compare(const Left, Right: ItemInfo): Integer; override;
end;
function ItemInfoComparer.Compare(const Left, Right: ItemInfo): Integer;
begin
if (Left.Name <> '') and (Right.Name <> '') then
Result := AnsiCompareStr(Left.Name, Right.Name)
else if (Left.Name <> '') then
Result := -1
else
Result := 1;
end;
procedure SortMyList(List: TStringList);
var
Compare: IComparer<ItemInfo>;
Items: TList<ItemInfo>;
Info: ItemInfo;
I: Integer;
InText: Boolean;
S: String;
begin
Compare := ItemInfoComparer.Create;
Items := TList<ItemInfo>.Create(Compare);
try
Items.Capacity := List.Count;
InText := False;
for I := 0 to List.Count-1 do
begin
S := Trim(List[i]);
if (S = '') or (S[1] = ';') then
begin
if InText then
Info.LeadingText := Info.LeadingText + #13 + List[i]
else
begin
Info.LeadingText := List[i];
InText := True;
end;
end else
begin
Info.Name := List.Names[I];
Info.Value := List.ValueFromIndex[I];
Items.Add(Info);
Info := Default(ItemInfo);
InText := False;
end;
end;
if InText then
Items.Add(Info);
Items.Sort;
List.Clear;
for I := 0 to Items.Count-1 do
begin
Info := Items[I];
if Info.LeadingText <> '' then
begin
for S in SplitString(Info.LeadingText, #13) do
List.Add(S);
end;
if Info.Name <> '' then
List.Add(Info.Name + '=' + Info.Value);
end;
finally
Items.Free;
end;
end;
Here is a simple procedure that will sort and also deal with spaces as cargo. I also added code to handle comments at the end of the file.
This will work with older versions of Delphi that do not have generics or advanced types as in Remy's answer (provided as convenience for those using older versions)
function SortKeys(List: TStringList; Index1, Index2: Integer): Integer;
begin
result := CompareText(List.Names[Index1], List.Names[Index2]);
end;
Procedure SortStringListWithComments(AStrings: TStrings);
var
LCargoText: TStringList;
LSortedText : TStringList;
s: string;
i : integer;
begin
LCargoText := nil;
LSortedText := TStringList.Create;
try
for i := 0 to AStrings.count-1 do
begin
s := Trim(AStrings[i]);
if (s='') or (s[1] = ';') then //LCargoText and blank lines attached to sorted strings (Boolean short circuit assumed here)
begin
if LCargoText = nil then
LCargoText := TStringList.Create;
LCargoText.Add(AStrings[i]);
end
else
begin
LSortedText.AddObject(AStrings[i], LCargoText);
LCargoText := nil; //set nil to deal with cases where we have no comments for a following key value pair
end;
end;
LSortedText.CustomSort(SortKeys);
// LSortedText.sort - will cause a1=x to be sorted before a=x
AStrings.clear;
for i := 0 to LSortedText.count-1 do
begin
if LSortedText.objects[i] <> nil then
begin
AStrings.AddStrings(TStringList(LSortedText.Objects[i]));
LSortedText.Objects[i].Free;
end;
AStrings.Add(LSortedText[i]);
end;
if LCargoText <> nil then
begin
AStrings.AddStrings(LCargoText) ; //comments orphaned at the end of the file
LCargoText.Free;
end;
finally
LSortedText.Free;
end;
end;
I programming with adodb/dbgo and try to use this code:
procedure TfrMain.dbeNoMejaKeyPress(Sender: TObject; var Key: Char);
begin
dmWarbam.TblTrans_temp.Filtered := False;
dmWarbam.TblTrans_temp.Filter := 'ID_ITEM = ' + QuotedStr(dbeNoMeja.Text);
dmWarbam.TblTrans_temp.Filtered := True;
end;
and
procedure TfrMain.dbeNoMejaChange(Sender: TObject);
begin
dmWarbam.TblTrans_temp.Filtered := False;
dmWarbam.TblTrans_temp.Filter := 'ID_ITEM = ' + QuotedStr(dbeNoMeja.Text);
dmWarbam.TblTrans_temp.Filtered := True;
end;
But none of above can work, when i press key on dbeNoMeja it didn't filter but instead the dataset inserting broken/incomplete data to database.
Can someone give me some example that working (full code)
If the dbedit is connected to the same table as the one you want to filter you have a problem, because the table goes into the dsEdit state once you start entering text.
Use a normal TEdit, and append a wildcard (*) to the string in the filter
dmWarbam.TblTrans_temp.Filter := 'ID_ITEM = ' + QuotedStr(edtNoMeja.Text+'*');
Code example adapted from Delphi-Neftalí. Nice and simple!
procedure TForm1.Edit1Change(Sender: TObject);
begin
// incremental search
ClientDataSet1.Locate('FirstName', Edit1.Text, [loCaseInsensitive, loPartialKey]);
Exit;
// actual data filtering
if (Edit1.Text = '') then begin
ClientDataSet1.Filtered := False;
ClientDataSet1.Filter := '';
end
else begin
ClientDataSet1.Filter := 'FirstName >= ' + QuotedStr(Edit1.Text);
ClientDataSet1.Filtered := True;
end;
end;
Setting ClientDataSet's provider to ADO DB (in your case):
Path := ExtractFilePath(Application.ExeName) + 'Data.MDB';
// Exist the MDB?
if FileExists(path) then begin
ClientDataSet1.ProviderName := 'DSProvider';
ADOQ.Open;
ClientDataSet1.Active := True;
ADOQ.Close;
ClientDataSet1.ProviderName := '';
lbldata.Caption := ExtractFileName(path);
Exit;
end;
I found a good solution in Expert Exchange,
unit dbg_filter_u;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, DBGrids, DBTables, Db, StdCtrls;
type
TForm1 = class(TForm)
Table1: TTable;
DataSource1: TDataSource;
Query1: TQuery;
DBGrid1: TDBGrid;
cbFilterBox: TComboBox; //a hidden combobox (Style = csDropDownList)
procedure Table1AfterOpen(DataSet: TDataSet);
procedure Table1AfterPost(DataSet: TDataSet);
procedure DBGrid1TitleClick(Column: TColumn);
procedure cbFilterBoxChange(Sender: TObject);
procedure cbFilterBoxClick(Sender: TObject);
procedure cbFilterBoxExit(Sender: TObject);
private
Procedure FillPickLists(ADBGrid : TDBGrid);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
//For Accessing some Protected Methods
type TCDBGrid = class(TCustomDBGrid);
//Storing the Values into the Picklist-Propertys of the asscociated Columns,
//this may cost time depending on the amount of the dataset
Procedure TForm1.FillPickLists(ADBGrid : TDBGrid);
const
SQL_Text = 'Select Distinct %s From %s';
var
q : TQuery;
i : integer;
Begin
If (Assigned(ADBGrid)) and
(Assigned(ADBGrid.Datasource)) and
(Assigned(ADBGrid.Datasource.DataSet)) Then
Begin
If (ADBGrid.Datasource.DataSet is ttable) Then
begin
q := TQuery.Create(self);
try
try
q.DatabaseName := TTable(ADBGrid.Datasource.DataSet).DataBaseName;
for i := 0 to ADBGrid.Columns.Count - 1 do //for each column
begin
if ADBGrid.Columns[i].Field.FieldKind = fkData then //only physical fields
begin
ADBGrid.Columns[i].ButtonStyle := cbsNone; //avoid button-showing
ADBGrid.Columns[i].PickList.Clear;
q.Close;
q.SQL.text := Format(SQL_Text,[ADBGrid.Columns[i].Field.FieldName,TTable(ADBGrid.Datasource.DataSet).TableName]);
q.Open;
While not q.eof do
begin
ADBGrid.Columns[i].PickList.Add(q.Fields[0].AsString);
q.next;
end;
q.close;
end;
end;
finally
q.free;
end;
except
raise;
end;
end else
Raise exception.Create('This Version works only for TTables');
end else
Raise Exception.Create('Grid not properly Assigned');
end;
//Initial-Fill
procedure TForm1.Table1AfterOpen(DataSet: TDataSet);
begin
FillPickLists(DBGrid1);
end;
//Refill after a change
procedure TForm1.Table1AfterPost(DataSet: TDataSet);
begin
FillPickLists(DBGrid1);
end;
//Show a Dropdownbox for selecting, instead the title on Titleclick
procedure TForm1.DBGrid1TitleClick(Column: TColumn);
var
ARect : Trect;
DummyTC : TColumn;
begin
If column.PickList.Count > 0 then
begin
cbFilterbox.Items.Assign(column.PickList);
ARect := TCDBGrid(Column.Grid).CalcTitleRect(Column,0,DummyTC);
cbfilterBox.top := Column.Grid.Top+1;
cbfilterBox.left := Column.Grid.left+Arect.Left+1;
cbFilterbox.Width := Column.Width;
cbFilterBox.Tag := Integer(Column); //Store the columnPointer
cbFilterBox.Show;
cbFilterBox.BringToFront;
cbFilterBox.DroppedDown := True;
end;
end;
//Build up the Filter
procedure TForm1.cbFilterBoxChange(Sender: TObject);
begin
cbFilterBox.Hide;
if cbFilterBox.Text <> TColumn(cbFilterBox.Tag).Title.Caption then
begin
Case TColumn(cbFilterBox.Tag).Field.DataType of
//Some Fieldtypes
ftstring :
TTable(TDBGrid(TColumn(cbFilterBox.Tag).Grid).Datasource.Dataset).Filter :=
TColumn(cbFilterBox.Tag).Field.FieldName+' = '+QuotedStr(cbFilterBox.Text);
ftInteger,
ftFloat :
TTable(TDBGrid(TColumn(cbFilterBox.Tag).Grid).Datasource.Dataset).Filter :=
TColumn(cbFilterBox.Tag).Field.FieldName+' = '+cbFilterBox.Text;
end;
TTable(TDBGrid(TColumn(cbFilterBox.Tag).Grid).Datasource.Dataset).Filtered := True;
end;
end;
//some Hiding-events
procedure TForm1.cbFilterBoxClick(Sender: TObject);
begin
cbFilterBox.Hide;
end;
procedure TForm1.cbFilterBoxExit(Sender: TObject);
begin
cbFilterBox.Hide;
end;
end.