I want to set my own procedure to OnGetText event of fields in a dynamic query
My procedure is like this :
procedure TMainFrm.MyFieldGetText(Sender: TField; var Text: String;
DisplayText: Boolean);
begin
...
end;
"...Captions" are String array constants
I set the event handler in OnAfterOpen event of ADOQuery :
procedure TImportFrm.ADOQueryAfterOpen(DataSet: TDataSet);
var
I : Integer;
begin
for I := 0 to ADOQuery.FieldCount - 1 do
ADOQuery.Fields[I].OnGetText := MainFrm.MyFieldGetText;
end;
But after opening ADOQuery , there is no Text to display , it looks like the Text value is empty !
It seems it doesn't matter what my procedure do , because when I set an empty procedure ( with no code ) , no text displayed too
what goes wrong ?
thanks ...
Try this:
procedure TMainFrm.MyFieldGetText(Sender: TField; var Text: String;
DisplayText: Boolean);
begin
if Sender.FieldName = 'XX' then
begin
Text := .... String(Sender.Value);// ( or Text := Sender.AsString);
end;
if Sender.FieldName = 'YY' then
begin
Text := .... String(Sender.Value);// ( or Text := Sender.AsString);
end;
...
end;
Thanks all
The problem was that I should mention all situations of Text and should use Sender.value instead of Text in right side ! , I changed my procedure to this and problem solved :
procedure TMainFrm.MyFieldGetText(Sender: TField; var Text: String;
DisplayText: Boolean);
begin
if Sender.AsVariant = Null then
Exit;
Text := Sender.AsString;
if MatchStr(Sender.FieldName, BooleanFieldNames) then
Text := BooleanCaptions[Sender.AsInteger];
if Sender.FieldName = 'BNStatus' then
Text := BNStatusCaptions[Sender.AsInteger];
if MatchStr(Sender.FieldName, ['FStatus', 'LStatus', 'FirstStatus']) then
Text := FLStatusCaptions[Sender.AsInteger];
if Sender.FieldName = 'PayType' then
Text := PayTypeCaptions[Sender.AsInteger];
if Sender.FieldName = 'BGType' then
Text := BGTypeCaptions[Sender.AsInteger];
if Sender.FieldName = 'Updated' then
Text := UpdatedCaptions[Sender.AsInteger];
if Sender.FieldName = 'DieUser' then
Text := DieUserCaptions[Sender.AsInteger];
if Sender.FieldName = 'LiveUser' then
Text := LiveUserCaptions[Sender.AsInteger];
if Sender.FieldName = 'NVStatus' then
Text := NVStatusCaptions[Sender.AsInteger];
if Sender.FieldName = 'BSGender' then
Text := BSGenderCaptions[Sender.AsInteger];
if Sender.FieldName = 'BSMType' then
Text := BSMTypeCaptions[Sender.AsInteger];
end;
Thanks again ...
Related
I want capture the url of active window based in a substring and add to Memo only if sActiveURL is different of sOldURL.
The trouble in my code is that always is added to Memo the same url ignoring the verification if sActiveURL <> sOldURL.
How fix this?
Main:
type
TForm1 = class(TForm)
tmr1: TTimer;
mmo1: TMemo;
procedure tmr1Timer(Sender: TObject);
private
{ Private declarations }
sActiveURL,sOldURL : string;
public
{ Public declarations }
end;
var
Form1: TForm1;
Flag: Boolean;
implementation
uses
UIAutomationClient_TLB, Activex, StrUtils;
{$R *.dfm}
function GetURL(hTargetWnd: HWND): string;
function Enumerar(pParent: IUIAutomationElement; Scope: TreeScope; pCondition: IUIAutomationCondition): String;
var
found : IUIAutomationElementArray;
ALen : Integer;
i : Integer;
iElement : IUIAutomationElement;
retorno: integer;
value : WideString;
iInter: IInterface;
ValPattern : IUIAutomationValuePattern;
begin
Result := '';
Flag := false;
if pParent = nil then
Exit;
pParent.FindAll(Scope, pCondition, found);
found.Get_Length(ALen);
for i := 1 to ALen - 1 do
begin
found.GetElement(i, iElement);
iElement.Get_CurrentControlType(retorno);
if (
(retorno = UIA_EditControlTypeId) or
(retorno = UIA_GroupControlTypeId)
) then
begin
iElement.GetCurrentPattern(UIA_ValuePatternId, iInter);
if Assigned(iInter) then
begin
if iInter.QueryInterface(IID_IUIAutomationValuePattern, ValPattern) = S_OK then
begin
ValPattern.Get_CurrentValue(value);
Result := trim(value);
Flag := true;
Break;
end;
end;
end;
if not Flag then
begin
Result := Enumerar(iElement, Scope, pCondition);
end;
end;
end;
var
UIAuto : IUIAutomation;
Ret : Integer;
RootElement : IUIAutomationElement;
Scope : TreeScope;
varProp : OleVariant;
pCondition : IUIAutomationCondition;
begin
Result := '';
try
UIAuto := CoCUIAutomation.Create;
if Succeeded(UIAuto.ElementFromHandle(hTargetWnd, RootElement)) then
begin
TVariantArg(varProp).vt := VT_BOOL;
TVariantArg(varProp).vbool := True;
UIAuto.CreatePropertyCondition(UIA_IsControlElementPropertyId,
varProp,
pCondition);
Scope := TreeScope_Element or TreeScope_Children;
Result := Enumerar(RootElement, Scope, pCondition);
end;
except
Result := '';
end;
end;
procedure TForm1.tmr1Timer(Sender: TObject);
begin
sActiveURL := GetURL(GetForegroundWindow);
if sActiveURL <> sOldURL then
begin
if AnsiContainsText(sActiveURL, 'stackoverflow.com') then
begin
sOldURL := sActiveURL;
mmo1.Lines.Add('['+sActiveURL+']<'+DateToStr(Date)+'>');
end;
end;
end;
UIAutomationClient_TLB.pas
EDITION:
On debug i discovered that none value is attrib to sOldURL variable.
procedure TForm1.tmr1Timer(Sender: TObject);
var
sActiveURL,sOldURL : string;
begin
sActiveURL := GetURL(GetForegroundWindow);
mmo1.Lines.Add('[sOldURL = '+sOldURL+' ]');
mmo1.Lines.Add('[sActiveURL = '+sActiveURL+' ]');
mmo1.Lines.Add('');
if sActiveURL <> sOldURL then
begin
if AnsiContainsText(sActiveURL, 'stackoverflow.com') then
begin
sOldURL := sActiveURL;
mmo1.Lines.Add(sActiveURL);
mmo1.Lines.Add('');
mmo1.Lines.Add('');
end;
end;
end;
The reason is as I shortly described in comments and is visible when the focused window is not your browser, for example your applications wiindow with the mmo1: TMemo:
GetForegroundWindow() returns the window that has focus.
Your GetURL(GetForegroundWindow) searches for an edit control (UIA_EditControlTypeId), of the focused window, and finds your memo control and returns the content of the memo.
Further, if you change focus to your browser, its URL will be correctly recorded in the memo, and if you return focus to your application, the condition if AnsiContainsText(sActiveURL, 'stackoverflow.com') will be true.
You then write to the memo, adding what you think is a real URL, and then this will be repeated for every timer event.
You need to only check the real browser window (skip all other) for its current URL. Try this, if you are using IE, otherwise you must modify FindWindow():
procedure TForm24.tmr1Timer(Sender: TObject);
var //
hIEWnd: HWND; //
begin
hIEWnd := FindWindow('IEFrame', nil); //
sActiveURL := GetURL(hIEWnd); //
// sActiveURL := GetURL(GetForegroundWindow);
if sActiveURL <> sOldURL then
begin
if AnsiContainsText(sActiveURL, 'stackoverflow.com') then
begin
sOldURL := sActiveURL;
mmo1.Lines.Add('[' + sActiveURL + ']<' + DateToStr(Date) + '>');
end;
end;
end;
Modified lines are marked with //
Here is how I am creating My PageControl.
PageCtrlSub := TPageControl.Create(Self);
PageCtrlSub.Parent := GroupSub;
PageCtrlSub.Align := alClient;
SubFormCnt := 0;
TblOdSub.First;
while not TblOdSub.Eof do
begin
SubPartNo := TblOdSub.FieldByName('sub_part_no').AsString;
AddNewSubTab(SubPartNo,Prc1Rs);
TblOdSub.Next;
end;
Here is how I am Creating my TabSheet and Form on the tabSheet.
procedure TFrmSub.AddNewSubTab(PartNo : String; PrcRs : TPriceRec);
var
i : Integer;
begin
inc(SubFormCnt);
TabSheet := TTabSheet.Create(PageCtrlSub);
TabSheet.Caption := 'Sub '+ intToStr(SubFormCnt);
TabSheet.PageControl := PageCtrlSub;
Form := TFrmSubExchange.Create(Self);
Form.Name := 'SForm' + IntToStr(SubFormCnt);
Form.Parent := TabSheet;
for i := 0 to Componentcount-1 do
begin
if (Components[i] is TFrmSubExchange) and (Components[i].Name = 'SForm' + IntToStr(SubFormCnt)) then
TFrmSubExchange(Components[i]).DataChangedSub(PartNo, PrcRs);
end;
Form.Show;
end;
I have a TCaption on each form that is created. When the user changes tab and press a button I need to know the text stored in the TCaption.caption property on the form of the active tab?
Thanks in Advance
Without seeing the DFM for TFrmSubExchange, this is just a guess, but you can try something like this:
procedure TFrmSub.SomeButtonClick(Sender: TObject);
var
s: string;
begin
s := (PageCtrlSub.ActivePage.Controls[0] as TFrmSubExchange).Caption1.Caption;
...
end;
I am trying to pass the content of AdvOfficeStatusBar1.Panels[0] to a Memo 4 of the frxreport1. The AdvOfficeStatusBar1.Panels[0] is date type (psDate). So before I open the report I would like the Memo to display my statusbar date.
I found out this by myself :
procedure TForm1.cxButton1Click(Sender: TObject);
var
Memo: TfrxMemoView;
Component: TfrxComponent;
begin
Component := frxReport1.FindObject('Memo4');
if Component is TfrxMemoView then
begin
Memo := Component as TfrxMemoView;
Memo.Text := AdvOfficeStatusBar1.Panels[0].Text;
frxReport1.ShowReport;
end;
end;
You can set the text of a fastreport memo from code like this:
procedure SetMemo(aReport: TfrxReport; aMemoName: string; aText: string);
var
memo: TfrxMemoView;
begin
memo := aReport.FindObject(aMemoName) as TfrxMemoView;
if memo <> nil then
memo.Text := aText;
end;
In C# language you can use the following:
report2.RegisterData(dt, "DataTable1");
TextObject t1 = (TextObject)report2.FindObject("Text1");
t1.Text = "I love Kurdistan!";
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.
I found this code over the net. This puts background color to the selected texts on Trichedit:
uses
RichEdit;
procedure RE_SetSelBgColor(RichEdit: TRichEdit; AColor: TColor);
var
Format: CHARFORMAT2;
begin
FillChar(Format, SizeOf(Format), 0);
with Format do
begin
cbSize := SizeOf(Format);
dwMask := CFM_BACKCOLOR;
crBackColor := AColor;
Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(#Format));
end;
end;
// Example: Set clYellow background color for the selected text.
procedure TForm1.Button1Click(Sender: TObject);
begin
RE_SetSelBgColor(RichEdit1, clYellow);
end;
However, what I need is to exclude space characters. Can someone help me? Any idea would be helpful?
My idea would be to select all space characters and then format it but then I don't know how to select them.
By the way, I am using delphi 2009.
#junmats, with this code you can select any word in a richedit control.
tested in Delphi 2010 and windows 7
uses
RichEdit;
procedure SetWordBackGroundColor(RichEdit : TRichEdit; aWord : String;AColor: TColor);
var
Format: CHARFORMAT2;
Index : Integer;
Len : Integer;
begin
FillChar(Format, SizeOf(Format), 0);
Format.cbSize := SizeOf(Format);
Format.dwMask := CFM_BACKCOLOR;
Format.crBackColor := AColor;
Index := 0;
Len := Length(RichEdit.Lines.Text) ;
Index := RichEdit.FindText(aWord, Index, Len, []);
while Index <> -1 do
begin
RichEdit.SelStart := Index;
RichEdit.SelLength := Length(aWord) ;
RichEdit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(#Format));
Index := RichEdit.FindText(aWord,Index + Length(aWord),Len, []) ;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetWordBackGroundColor(RichEdit1,' ',clYellow);// will mark all spaces
end;
if you wanna select all words except the spaces, you can do something like this
Procedure GetListofWords(Text : String; var ListofWords : TStringList);
var
DummyStr : String;
FoundWord : String;
begin
DummyStr := Text;
FoundWord := '';
if (Length(Text) = 0) then exit;
while (Pos(' ', DummyStr) > 0) do
begin
FoundWord := Copy(DummyStr, 1, Pos(' ', DummyStr) - 1);
ListofWords.Add(FoundWord);
DummyStr := Copy(DummyStr, Pos(' ', DummyStr) + 1, Length(DummyStr) - Length(FoundWord) + 1);
end;
if (Length(DummyStr) > 0) then
ListofWords.Add(DummyStr);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
ListofWords : TStringList;
i : integer;
begin
ListofWords:=TStringList.Create;
try
GetListofWords(RichEdit1.Lines.Text,ListofWords);
if ListofWords.Count>0 then
for i:=0 to ListofWords.Count - 1 do
SetWordBackGroundColor(RichEdit1,ListofWords[i],clYellow);
finally
ListofWords.Clear;
ListofWords.Free;
end;
end;