Adding Characters one by one to TMemo - delphi

Could any one tell me how can I add characters one by one from a text file to a Memo?
The text file contains different paragraphs of texts. I want to add the characters of each paragraph one by one till the end of the paragraph. Then after 10 seconds delay the next paragraph to be shown in the Memo.
Thanks,
Sei

You would probably use a TTimer. Drop a TTimer, a TMemo and a TButton on your form. Then do
var
lines: TStringList;
pos: TPoint;
const
CHAR_INTERVAL = 75;
PARAGRAPH_INTERVAL = 1000;
procedure TForm6.Button1Click(Sender: TObject);
const
S_EMPTY_FILE = 'You are trying to display an empty file!';
begin
Memo1.ReadOnly := true;
Memo1.Clear;
Memo1.Lines.Add('');
pos := Point(0, 0);
if lines.Count = 0 then
raise Exception.Create(S_EMPTY_FILE);
while (pos.Y < lines.Count) and (length(lines[pos.Y]) = 0) do inc(pos.Y);
if pos.Y = lines.Count then
raise Exception.Create(S_EMPTY_FILE);
NextCharTimer.Enabled := true;
end;
procedure TForm6.FormCreate(Sender: TObject);
begin
lines := TStringList.Create;
lines.LoadFromFile('C:\Users\Andreas Rejbrand\Desktop\Test.txt');
end;
procedure TForm6.NextCharTimerTimer(Sender: TObject);
begin
NextCharTimer.Interval := CHAR_INTERVAL;
Memo1.Lines[Memo1.Lines.Count - 1] := Memo1.Lines[Memo1.Lines.Count - 1] + lines[pos.Y][pos.X + 1];
inc(pos.X);
if pos.X = length(lines[pos.Y]) then
begin
NextCharTimer.Interval := PARAGRAPH_INTERVAL;
pos.X := 0;
repeat
inc(pos.Y);
Memo1.Lines.Add('');
until (pos.Y = lines.Count) or (length(lines[pos.Y]) > 0);
end;
if pos.Y = lines.Count then
NextCharTimer.Enabled := false;
end;

A thread alternative to a timer. Tests a 'carriage return' in the file for a paragraph:
const
UM_MEMOCHAR = WM_USER + 22;
type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure UMMemoChar(var Msg: TMessage); message UM_MEMOCHAR;
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
type
TCharSender = class(TThread)
private
FCharWait, FParWait: Integer;
FFormHandle: HWND;
FFS: TFileStream;
protected
procedure Execute; override;
public
constructor Create(FileName: string; CharWait, ParagraphWait: Integer;
FormHandle: HWND);
destructor Destroy; override;
end;
constructor TCharSender.Create(FileName: string; CharWait, ParagraphWait: Integer;
FormHandle: HWND);
begin
FCharWait := CharWait;
FParWait := ParagraphWait;
FFormHandle := FormHandle;
FFS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
FreeOnTerminate := True;
inherited Create(False);
end;
destructor TCharSender.Destroy;
begin
FFS.Free;
inherited;
end;
procedure TCharSender.Execute;
var
C: Char;
begin
while (FFS.Position < FFS.Size) and not Terminated do begin
FFS.Read(C, SizeOf(C));
if (C <> #10) then
PostMessage(FFormHandle, UM_MEMOCHAR, Ord(C), 0);
if C = #13 then
Sleep(FParWait)
else
Sleep(FCharWait);
end;
end;
{TForm1}
procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Clear;
TCharSender.Create(
ExtractFilePath(Application.ExeName) + 'text.txt', 20, 1000, Handle);
end;
procedure TForm1.UMMemoChar(var Msg: TMessage);
begin
Memo1.SelStart := Memo1.Perform(WM_GETTEXTLENGTH, 0, 0);
Memo1.Perform(WM_CHAR, Msg.WParam, 0);
end;

There's lots of ways to do this, and I'm not sure how you intend to handle newlines. However, all routes lead to TMemo.Lines which is a TStrings instance that wraps up the windows messages needed to interact with the underlying Windows edit control.
For example, these routines should get you started.
procedure AddNewLine(Memo: TMemo);
begin
Memo.Lines.Add('');
end;
procedure AddCharacter(Memo: TMemo; const C: Char);
var
Lines: TStrings;
begin
Lines := Memo.Lines;
if Lines.Count=0 then
AddNewLine(Memo);
Lines[Lines.Count-1] := Lines[Lines.Count-1]+C;
end;

Related

How to create popup menu with scroll bar that also supports sub-menus

I want to add scroll bars (and/or scroll wheel support) to my existing Delphi application's popup menus, because they are often higher than the screen, and the built in scrolling is not good enough. How to make a popup menu with scrollbar? would be a great solution for me, except that it doesn't support sub-menus, which I absolutely require. The author of that solution hasn't been on StackOverflow since last July, so I don't think he'll reply to my comment. Can anyone see how to modify that code to add support for sub-menus? In case it matters, I need it to work with Delphi 2007.
I share #KenWhite's reservations about how users might receive a huge menu. So apologies to him and readers whose sensibilities the following might offend ;=)
Anyway, I hope the code below shows that in principle, it is straightforward
to create a TreeView based on a TPopUpMenu (see the routine PopUpMenuToTree) which reflects the structure of the PopUpMenu, including sub-items,
and make use of the TreeView's automatic vertical scroll bar. In the code, the
PopUpMenu happens to be on the same form as the TreeView, but that's only for
compactness, of course - the PopUpMenu could be on anothe form entirely.
As mentioned in a comment, personally I would base something like this on a
TVirtualTreeView (http://www.soft-gems.net/index.php/controls/virtual-treeview)
because it is far more customisable than a standard TTreeView.
type
TForm1 = class(TForm)
PopupMenu1: TPopupMenu;
TreeView1: TTreeView; // alClient-aligned
Start1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure TreeView1Click(Sender: TObject);
private
protected
procedure MenuItemClick(Sender : TObject);
procedure PopUpMenuToTree(PopUpMenu : TPopUpMenu; TreeView : TTreeView);
public
end;
var
Form1: TForm1;
[...]
procedure TForm1.FormCreate(Sender: TObject);
var
Item,
SubItem : TMenuItem;
i,
j : Integer;
begin
// (Over)populate a PopUpMenu
for i := 1 to 50 do begin
Item := TMenuItem.Create(PopUpMenu1);
Item.Caption := 'Item ' + IntToStr(i);
Item.OnClick := MenuItemClick;
PopUpMenu1.Items.Add(Item);
for j := 1 to 5 do begin
SubItem := TMenuItem.Create(PopUpMenu1);
SubItem.Caption := Format('Item %d Subitem %d ', [i, j]);
SubItem.OnClick := MenuItemClick;
Item.Add(SubItem);
end;
end;
// Populate a TreeView from the PopUpMenu
PopUpMenuToTree(PopUpMenu1, TreeView1);
end;
procedure TForm1.MenuItemClick(Sender: TObject);
var
Item : TMenuItem;
begin
if Sender is TMenuItem then
Caption := TMenuItem(Sender).Caption + ' clicked';
end;
procedure TForm1.PopUpMenuToTree(PopUpMenu: TPopUpMenu;
TreeView: TTreeView);
// Populates the TreeView with the Items in the PopUpMenu
var
i : Integer;
Item : TMenuItem;
RootNode : TTreeNode;
procedure AddItem(Item : TMenuItem; ParentNode : TTreeNode);
var
Node : TTreeNode;
j : Integer;
begin
Node := TreeView.Items.AddChildObject(ParentNode, Item.Caption, Item);
for j := 0 to Item.Count - 1 do begin
AddItem(Item.Items[j], Node);
end;
end;
begin
TreeView.Items.BeginUpdate;
TreeView.Items.Clear;
try
for i := 0 to PopUpMenu.Items.Count - 1 do begin
AddItem(PopUpMenu.Items[i], Nil);
end;
finally
TreeView.Items.EndUpdate;
end;
end;
procedure TForm1.TreeView1Click(Sender: TObject);
var
Node : TTreeNode;
Item : TMenuItem;
begin
if Sender is TTreeView then begin
Node := TTreeView(Sender).Selected;
Item := TMenuItem(Node.Data);
Item.Click;
end;
end;
Here's what I have done, by merging How to make a popup menu with scrollbar?, MartynA's code, and some of my own:
unit PopupUnit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, Menus, ComCtrls;
type
TPopupMode = (pmStandard, pmCustom);
TPopupMenu = class(Menus.TPopupMenu)
private
FPopupForm: TForm;
FPopupMode: TPopupMode;
public
constructor Create(AOwner: TComponent); override;
procedure Popup(X, Y: Integer); override;
property PopupForm: TForm read FPopupForm write FPopupForm;
property PopupMode: TPopupMode read FPopupMode write FPopupMode;
end;
type
TPopupForm = class(TForm)
private
FPopupForm: TForm;
FPopupMenu: TPopupMenu;
FTreeView: TTreeView;
procedure DoResize;
procedure TreeViewClick(Sender: TObject);
procedure TreeViewCollapsedOrExpanded(Sender: TObject; Node: TTreeNode);
procedure TreeViewKeyPress(Sender: TObject; var Key: Char);
procedure WMActivate(var AMessage: TWMActivate); message WM_ACTIVATE;
protected
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent; APopupForm: TForm;
APopupMenu: TPopupMenu); reintroduce;
end;
var
PopupForm: TPopupForm;
implementation
{$R *.dfm}
{ TPopupForm }
constructor TPopupForm.Create(AOwner: TComponent; APopupForm: TForm;
APopupMenu: TPopupMenu);
procedure AddItem(Item : TMenuItem; ParentNode : TTreeNode);
var
I : Integer;
Node : TTreeNode;
begin
if Item.Caption <> '-' then begin
Node := FTreeView.Items.AddChildObject(ParentNode, Item.Caption, Item);
Node.ImageIndex := Item.ImageIndex;
for I := 0 to Item.Count - 1 do begin
AddItem(Item.Items[I], Node);
end;
end;
end;
var
I: Integer;
begin
inherited Create(AOwner);
BorderStyle := bsNone;
FPopupForm := APopupForm;
FPopupMenu := APopupMenu;
FTreeView := TTreeView.Create(Self);
FTreeView.Parent := Self;
FTreeView.Align := alClient;
FTreeView.BorderStyle := bsSingle;
FTreeView.Color := clMenu;
FTreeView.Images := FPopupMenu.Images;
FTreeView.ReadOnly := TRUE;
FTreeView.ShowHint := FALSE;
FTreeView.ToolTips := FALSE;
FTreeView.OnClick := TreeViewClick;
FTreeView.OnCollapsed := TreeViewCollapsedOrExpanded;
FTreeView.OnExpanded := TreeViewCollapsedOrExpanded;
FTreeView.OnKeyPress := TreeViewKeyPress;
FTreeView.Items.BeginUpdate;
try
FTreeView.Items.Clear;
for I := 0 to FPopupMenu.Items.Count - 1 do
begin
AddItem(FPopupMenu.Items[I], NIL);
end;
finally
FTreeView.Items.EndUpdate;
end;
DoResize;
end;
procedure TPopupForm.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW;
end;
procedure TPopupForm.DoResize;
const
BORDER = 2;
var
ItemRect, TVRect : TRect;
MF : TForm;
Node : TTreeNode;
begin
TVRect := Rect(0, 0, 0, 0);
Node := FTreeView.Items[0];
while Node <> NIL do begin
ItemRect := Node.DisplayRect(TRUE);
ItemRect.Right := ItemRect.Right + FTreeView.Images.Width + 1;
if ItemRect.Left < TVRect.Left then
TVRect.Left := ItemRect.Left;
if ItemRect.Right > TVRect.Right then
TVRect.Right := ItemRect.Right;
if ItemRect.Top < TVRect.Top then
TVRect.Top := ItemRect.Top;
if ItemRect.Bottom > TVRect.Bottom then
TVRect.Bottom := ItemRect.Bottom;
Node := Node.GetNextVisible;
end;
MF := Application.MainForm;
if Top + TVRect.Bottom - TVRect.Top > MF.Top + MF.ClientHeight then begin
TVRect.Bottom := TVRect.Bottom -
(Top + TVRect.Bottom - TVRect.Top - (MF.Top + MF.ClientHeight));
end;
if Left + TVRect.Right - TVRect.Left > MF.Left + MF.ClientWidth then begin
TVRect.Right := TVRect.Right -
(Left + TVRect.Right - TVRect.Left - (MF.Left + MF.ClientWidth));
end;
ClientHeight := TVRect.Bottom - TVRect.Top + BORDER * 2;
ClientWidth := TVRect.Right - TVRect.Left + BORDER * 2;
end;
procedure TPopupForm.TreeViewClick(Sender: TObject);
var
Node : TTreeNode;
Item : TMenuItem;
begin
if Sender is TTreeView then begin
Node := TTreeView(Sender).Selected;
if assigned(Node) then begin
Item := TMenuItem(Node.Data);
if assigned(Item.OnClick) then begin
Item.Click;
Close;
end;
end;
end;
end;
procedure TPopupForm.TreeViewCollapsedOrExpanded(Sender: TObject;
Node: TTreeNode);
begin
DoResize;
end;
procedure TPopupForm.TreeViewKeyPress(Sender: TObject; var Key: Char);
begin
if Ord(Key) = VK_RETURN then begin
TreeViewClick(Sender);
end
else if Ord(Key) = VK_ESCAPE then begin
Close;
end;
end;
procedure TPopupForm.WMActivate(var AMessage: TWMActivate);
begin
SendMessage(FPopupForm.Handle, WM_NCACTIVATE, 1, 0);
inherited;
if AMessage.Active = WA_INACTIVE then
Release;
FTreeView.Select(NIL, []);
end;
{ TPopupMenu }
constructor TPopupMenu.Create(AOwner: TComponent);
begin
inherited;
FPopupMode := pmStandard;
end;
procedure TPopupMenu.Popup(X, Y: Integer);
begin
case FPopupMode of
pmCustom:
with TPopupForm.Create(nil, FPopupForm, Self) do
begin
Top := Y;
Left := X;
Show;
end;
pmStandard: inherited;
end;
end;
end.

Firemonkey Edit/Combo autocomplete/autosuggest while typing

What is the way to implement Autocomplete or Autosuggest with Delphi/Firemonkey for Windows/Android platforms as well as MacOS and iOS?
Example
When user types text in Google search box - some quick suggestions are shown.
There are lots of implementations for VCL with IAutoComplete, but there are less for FMX. What is needed is - FMX
I've made some research and compiled from different sources what I got below.
I've tested this on XE7/XE8 with Firemonkey. Perfectly runnig on Win32, Android and pretty sure MacOS.
I used to call suggestions within a timer, but the code below comes without a timer. The procedure to call in a timer or a thread is TStyledSuggestEdit.DropDownRecalc.
unit FMX.Edit.Suggest2;
interface
uses
FMX.Edit.Style, FMX.Controls.Presentation, FMX.Controls.Model, FMX.Presentation.Messages, FMX.Edit,
FMX.Controls, FMX.ListBox, System.Classes, System.Types;
const
PM_DROP_DOWN = PM_EDIT_USER + 10;
PM_PRESSENTER = PM_EDIT_USER + 11;
PM_SET_ITEMINDEX = PM_EDIT_USER + 12;
PM_GET_ITEMINDEX = PM_EDIT_USER + 13;
PM_GET_SELECTEDITEM = PM_EDIT_USER + 14;
PM_SET_ITEMCHANGE_EVENT = PM_EDIT_USER + 15;
PM_GET_ITEMS = PM_EDIT_USER + 16;
type
TSelectedItem = record
Text: String;
Data: TObject;
end;
TStyledSuggestEdit = class(TStyledEdit)
private
FItems: TStrings;
FPopup: TPopup;
FListBox: TListBox;
FDropDownCount: Integer;
FOnItemChange: TNotifyEvent;
FItemIndex: integer;
FDontTrack: Boolean;
FLastClickedIndex: Integer;
function _GetIndex: Integer;
procedure _SetIndex(const Value: Integer);
procedure _SetItems(const Value: TStrings);
protected
procedure CheckIfTextMatchesSuggestions; // used to find out if a typed text matches any of suggestions and then do select
function GetListBoxIndexByText(const AText: string): Integer;
procedure OnItemClick(const Sender: TCustomListBox; const Item: TListBoxItem);
procedure PMDropDown(var AMessage: TDispatchMessage); message PM_DROP_DOWN;
procedure MMDataChanged(var AMessage: TDispatchMessageWithValue<TDataRecord>); message MM_DATA_CHANGED;
procedure PMSetSize(var AMessage: TDispatchMessageWithValue<TSizeF>); message PM_SET_SIZE;
procedure PMGetItemIndex(var AMessage: TDispatchMessageWithValue<Integer>); message PM_GET_ITEMINDEX;
procedure PMSetItemIndex(var AMessage: TDispatchMessageWithValue<Integer>); message PM_SET_ITEMINDEX;
procedure PMGetItems(var AMessage: TDispatchMessageWithValue<TStrings>); message PM_GET_ITEMS;
procedure PMGetSelectedItem(var AMEssage: TDispatchMessageWithValue<TSelectedItem>); message PM_GET_SELECTEDITEM;
procedure PMSetItemChangeEvent(var AMessage: TDispatchMessageWithValue<TNotifyEvent>); message PM_SET_ITEMCHANGE_EVENT;
procedure PMPressEnter(var AMessage: TDispatchMessage); message PM_PRESSENTER;
procedure DoChangeTracking; override;
procedure RebuildSuggestionList(AText: String);
procedure RecalculatePopupHeight;
procedure KeyDown(var Key: Word; var KeyChar: Char; Shift: TShiftState); override;
procedure DropDownRecalc(ByText: string; Delay: integer = 100); //Delay parameter is a preparation for calling by a thread or a timer
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function _SelectedItem: TSelectedItem;
property _Items: TStrings read FItems write _SetItems;
property _ItemIndex: Integer read _GetIndex write _SetIndex;
property _OnItemChange: TNotifyEvent read FOnItemChange write FOnItemChange;
end;
TStyleSuggestEditProxy = class(TPresentationProxy)
protected
function CreateReceiver: TObject; override;
end;
TEditSuggestHelper = class helper for TEdit
public type
private
function GetIndex: Integer;
procedure SetIndex(const Value: Integer);
procedure SetOnItemChange(const Value: TNotifyEvent);
function GetItems: TStrings;
public
procedure AssignItems(const S: TStrings);
procedure ForceDropDown;
procedure PressEnter;
function SelectedItem: TSelectedItem;
property OnItemChange: TNotifyEvent write SetOnItemChange;
property ItemIndex: Integer read GetIndex write SetIndex;
property Items: TStrings read GetItems;
end;
implementation
uses
FMX.Presentation.Factory, FMX.Types, System.SysUtils, System.Math, System.Rtti, uDsTimers.FMX, {$IFDEF MSWINDOWS}Winapi.Windows,{$ENDIF}
System.UITypes;
{ TStyleSuggestEditProxy }
function TStyleSuggestEditProxy.CreateReceiver: TObject;
begin
Result := TStyledSuggestEdit.Create(nil);
end;
{ TStyledSuggestEdit }
procedure TStyledSuggestEdit.CheckIfTextMatchesSuggestions;
var I: integer;
begin
if FItemIndex = -1 then
begin
I := self.GetListBoxIndexByText(Edit.Text);
if I <> -1 then
try
OnItemClick(nil, FListBox.ListItems[I]); //try-except: maybe missing items if calling from a timer event or within a thread
FListBox.RemoveObject(FListBox.ListItems[I]);
RecalculatePopupHeight;
except
end;
end;
end;
constructor TStyledSuggestEdit.Create(AOwner: TComponent);
begin
inherited;
FItems := TStringList.Create;
FItemIndex := -1;
FPopup := TPopup.Create(self);
FPopup.Parent := Self;
FPopup.PlacementTarget := Self;
FPopup.Placement := TPlacement.Bottom;
FPopup.Width := Width;
FListBox := TListBox.Create(self);
FListBox.Parent := FPopup;
FListBox.Align := TAlignLayout.Client;
FListBox.OnItemClick := OnItemClick;
FDropDownCount := 5;
FListBox.Width := Self.Width;
FPopup.Width := Self.Width;
FLastClickedIndex := -1;
end;
destructor TStyledSuggestEdit.Destroy;
begin
FPopup := nil;
FListBox := nil;
FItems.Free;
inherited;
end;
procedure TStyledSuggestEdit.DoChangeTracking;
begin
inherited;
if Edit.Text <> _SelectedItem.Text then
FLastClickedIndex := -1;
if not FDontTrack and (FLastClickedIndex = -1) then
begin
_ItemIndex := -1;
DropDownRecalc(Edit.Text);
end;
end;
function TStyledSuggestEdit.GetListBoxIndexByText(const AText: string): Integer;
begin
for Result := 0 to FListBox.Count - 1 do
if FListBox.ListItems[Result].Text.ToLower = AText.ToLower then
Exit;
Result := -1;
end;
function TStyledSuggestEdit._GetIndex: Integer;
begin
Result := FItemIndex;
end;
procedure TStyledSuggestEdit.KeyDown(var Key: Word; var KeyChar: Char; Shift: TShiftState);
begin
inherited;
case Key of
vkReturn:
if FListBox.Selected <> nil then
begin
OnItemClick(FListBox, FListBox.Selected);
end;
vkEscape: FPopup.IsOpen := False;
vkDown: begin
if FListBox.Selected <> nil then
FListBox.ItemIndex := Min(FListBox.Count - 1, FListBox.ItemIndex + 1)
else
if FListBox.Count > 0 then
FListBox.ItemIndex := 0;
end;
vkUp: begin
if FListBox.Selected <> nil then
FListBox.ItemIndex := Max(0, FListBox.ItemIndex - 1);
end;
end;
if Assigned(OnKeyDown) then
OnKeyDown(Edit, Key, KeyChar, Shift);
end;
procedure TStyledSuggestEdit.MMDataChanged(var AMessage: TDispatchMessageWithValue<TDataRecord>);
var
Data: TDataRecord;
begin
Data := AMessage.Value;
if Data.Value.IsType <TStrings> and (Data.Key = 'Suggestions') then
FItems.Assign(Data.Value.AsType<TStrings>)
end;
procedure TStyledSuggestEdit.OnItemClick(const Sender: TCustomListBox; const Item: TListBoxItem);
begin
FLastClickedIndex := Item.Tag;
_ItemIndex := Item.Tag;
FPopup.IsOpen := Sender = nil; // whenever OnItemClick is being called programmatically `Sender` must be passed as `nil`,
Edit.SetFocus; // otherwise considered as real-user-click and should close popup
end;
procedure TStyledSuggestEdit.PMPressEnter(var AMessage: TDispatchMessage);
var K: word; KC: Char;
begin
K := vkReturn;
KC := #13;
KeyDown(K, KC, []);
end;
procedure TStyledSuggestEdit.PMDropDown(var AMessage: TDispatchMessage);
begin
inherited;
DropDownRecalc('',10);
end;
procedure TStyledSuggestEdit.PMGetItemIndex(var AMessage: TDispatchMessageWithValue<Integer>);
begin
AMessage.Value := self._ItemIndex;
end;
procedure TStyledSuggestEdit.PMGetItems(var AMessage: TDispatchMessageWithValue<TStrings>);
begin
AMessage.Value := Self._Items;
end;
procedure TStyledSuggestEdit.PMGetSelectedItem(var AMEssage: TDispatchMessageWithValue<TSelectedItem>);
begin
AMEssage.Value := self._SelectedItem;
end;
procedure TStyledSuggestEdit.PMSetItemChangeEvent(var AMessage: TDispatchMessageWithValue<TNotifyEvent>);
begin
FOnItemChange := AMessage.Value;
end;
procedure TStyledSuggestEdit.PMSetItemIndex(var AMessage: TDispatchMessageWithValue<Integer>);
begin
self._ItemIndex := AMessage.Value;
end;
procedure TStyledSuggestEdit.PMSetSize(var AMessage: TDispatchMessageWithValue<TSizeF>);
begin
inherited;
FPopup.Width := Width;
end;
procedure TStyledSuggestEdit.RebuildSuggestionList(AText: String);
var
i: integer;
Word: string;
begin
FListBox.Clear;
FListBox.BeginUpdate;
AText := AText.ToLower;
try
for i := 0 to FItems.Count - 1 do
if AText.IsEmpty or FItems[i].ToLower.StartsWith(AText) then
begin
FListBox.AddObject(TListBoxItem.Create(FListBox));
FListBox.ListItems[FListBox.Count - 1].Tag := I;
FListBox.ListItems[FListBox.Count - 1].Data := FItems.Objects[i];
FListBox.ListItems[FListBox.Count - 1].Text := FItems[i];
end;
finally
FListBox.EndUpdate;
end;
end;
procedure TStyledSuggestEdit.RecalculatePopupHeight;
begin
if FListBox.Items.Count > 0 then
begin
FPopup.Height := FListBox.ListItems[0].Height * Min(FDropDownCount, FListBox.Items.Count) + FListBox.BorderHeight;
FPopup.PopupFormSize := TSizeF.Create(FPopup.Width, FPopup.Height);
end
else
begin
FPopup.Height := 1; // instead this it's possible to hide FPopup.IsOpen := false;
FPopup.PopupFormSize := TSizeF.Create(FPopup.Width, FPopup.Height);
end;
end;
function TStyledSuggestEdit._SelectedItem: TSelectedItem;
begin
if FItemIndex = -1 then
begin
Result.Text := '';
Result.Data := nil;
end
else
begin
Result.Text := FItems[FItemIndex];
Result.Data := FItems.Objects[FItemIndex];
end;
end;
procedure TStyledSuggestEdit._SetIndex(const Value: Integer);
begin
if (Value >= -1) and (Value < FItems.Count) and (Value <> FItemIndex) then
begin
FDontTrack := true;
FItemIndex := Value;
if (FItemIndex >= 0) and (Edit.Text <> _SelectedItem.Text) then
begin
Edit.Text := _SelectedItem.Text;
Edit.GoToTextEnd;
end;
if Assigned(FOnItemChange) then
FOnItemChange(Edit);
FDontTrack := false;
end;
end;
procedure TStyledSuggestEdit._SetItems(const Value: TStrings);
begin
FItems := Value;
_ItemIndex := -1;
end;
procedure TStyledSuggestEdit.DropDownRecalc(ByText: string; Delay: integer);
begin
// Here is possible to use a timer call or a call in a thread;
if not self.FDontTrack then
begin
Self.RebuildSuggestionList(ByText);
Self.RecalculatePopupHeight;
self.FPopup.IsOpen := self.FListBox.Items.Count > 0;
CheckIfTextMatchesSuggestions;
end;
end;
{ TEditHelper }
procedure TEditSuggestHelper.PressEnter;
begin
if HasPresentationProxy then
PresentationProxy.SendMessage(PM_PRESSENTER);
end;
function TEditSuggestHelper.SelectedItem: TSelectedItem;
begin
if HasPresentationProxy then
PresentationProxy.SendMessageWithResult<TSelectedItem>(PM_GET_SELECTEDITEM, Result);
end;
procedure TEditSuggestHelper.SetIndex(const Value: Integer);
begin
if HasPresentationProxy then
PresentationProxy.SendMessage<Integer>(PM_SET_ITEMINDEX, Value);
end;
procedure TEditSuggestHelper.SetOnItemChange(const Value: TNotifyEvent);
begin
if HasPresentationProxy then
PresentationProxy.SendMessage<TNotifyEvent>(PM_SET_ITEMCHANGE_EVENT, Value);
end;
procedure TEditSuggestHelper.ForceDropDown;
begin
if HasPresentationProxy then
PresentationProxy.SendMessage(PM_DROP_DOWN);
end;
function TEditSuggestHelper.GetIndex: Integer;
begin
if HasPresentationProxy then
PresentationProxy.SendMessageWithResult<Integer>(PM_GET_ITEMINDEX, Result);
end;
function TEditSuggestHelper.GetItems: TStrings;
begin
if HasPresentationProxy then
PresentationProxy.SendMessageWithResult<TStrings>(PM_GET_ITEMS, Result);
end;
procedure TEditSuggestHelper.AssignItems(const S: TStrings);
begin
self.Model.Data['Suggestions'] := TValue.From<TStrings>(S);
end;
initialization
TPresentationProxyFactory.Current.Register('SuggestEditStyle', TStyleSuggestEditProxy);
finalization
TPresentationProxyFactory.Current.Unregister('SuggestEditStyle');
end.
Here is how you use it:
Create Multi-Device application
On a HD form place common TEdit component
Define for TEdit.OnPresentationNameChoosing on Events tab the following:
procedure TForm1.Edit1PresentationNameChoosing(Sender: TObject; var PresenterName: string);
begin
inherited;
PresenterName := 'SuggestEditStyle';
end;
Add items to your sl: TStrings by: sl.AddObject('Name', TIntObj.Create(10));
Assign sl: TStrings to your Edit by: Edit1.AssignItems(sl);
Comment out TStyledSuggestEdit.CheckIfTextMatchesSuggestions in the code if you don't need Autoselect ability while typing.
Test Form1
Form reference
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 325
ClientWidth = 225
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
object Edit1: TEdit
Touch.InteractiveGestures = [LongTap, DoubleTap]
Align = Top
TabOrder = 0
OnPresentationNameChoosing = Edit1PresentationNameChoosing
Position.X = 20.000000000000000000
Position.Y = 57.000000000000000000
Margins.Left = 20.000000000000000000
Margins.Right = 20.000000000000000000
Size.Width = 185.000000000000000000
Size.Height = 22.000000000000000000
Size.PlatformDefault = False
object Button2: TButton
Align = Right
Cursor = crArrow
Margins.Left = 1.000000000000000000
Margins.Top = 1.000000000000000000
Margins.Right = 1.000000000000000000
Margins.Bottom = 1.000000000000000000
Position.X = 156.500000000000000000
Position.Y = 0.500000000000000000
Scale.X = 0.500000000000000000
Scale.Y = 0.500000000000000000
Size.Width = 56.000000000000000000
Size.Height = 42.000000000000000000
Size.PlatformDefault = False
StyleLookup = 'arrowdowntoolbutton'
TabOrder = 0
Text = 'Button2'
OnClick = Button2Click
end
end
object Button1: TButton
Align = Top
Margins.Left = 30.000000000000000000
Margins.Top = 10.000000000000000000
Margins.Right = 30.000000000000000000
Position.X = 30.000000000000000000
Position.Y = 89.000000000000000000
Size.Width = 165.000000000000000000
Size.Height = 22.000000000000000000
Size.PlatformDefault = False
TabOrder = 1
Text = 'Set 3rd item'
OnClick = Button1Click
end
object Label1: TLabel
Align = Top
Size.Width = 225.000000000000000000
Size.Height = 57.000000000000000000
Size.PlatformDefault = False
Text = 'Label1'
end
end
Code reference
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Controls.Presentation, FMX.Edit, FMX.Edit.Suggest2, FMX.Layouts, FMX.ListBox,
FMX.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Button2: TButton;
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure esItemChange(Sender: TObject);
procedure Edit1PresentationNameChoosing(Sender: TObject; var PresenterName: string);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
sl: TStrings;
implementation
{$R *.fmx}
type
TIntObj = class(TObject)
private
FId: integer;
public
constructor Create(Id: integer); overload;
function Value: integer;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.ItemIndex := 3; // force choice as if it was combobox behaviour
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
Edit1.ForceDropDown; // add a button inside TEdit and use it as dropdown
end;
procedure TForm1.Edit1PresentationNameChoosing(Sender: TObject; var PresenterName: string);
begin
inherited;
PresenterName := 'SuggestEditStyle';
end;
procedure TForm1.esItemChange(Sender: TObject);
begin
// occurs when ItemIndex is changed
Label1.Text := TEdit(Sender).SelectedItem.Text + LineFeed + 'idx=' + TEdit(Sender).ItemIndex.ToString + LineFeed + 'data=';
if TEdit(Sender).SelectedItem.Data <> nil then
Label1.Text := Label1.Text + TIntObj(TEdit(Sender).SelectedItem.Data).Value.ToString
else
Label1.Text := Label1.Text + 'nil';
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
sl := TStringList.Create;
//sl.AddObject('aaa',10); // Segmentation fault 11 under Android
sl.AddObject('aaa',TIntObj.Create(10));
sl.AddObject('aaabb',TIntObj.Create(20));
sl.AddObject('aaabbbcc',TIntObj.Create(30));
sl.AddObject('aaacc',TIntObj.Create(40));
sl.AddObject('aaafff',TIntObj.Create(50));
sl.AddObject('aaaggg',TIntObj.Create(60));
Edit1.AssignItems(sl);
Edit1.OnItemChange := esItemChange;
end;
{ TIntObject }
constructor TIntObj.Create(Id: integer);
begin
inherited Create;
FId := Id;
end;
function TIntObj.Value: integer;
begin
Result := FId;
end;
end.
Tested Win32 [Windows 7/8] and Android 4.4.4 device [MI3W]
Hope this helps. Any further ideas and suggestions are appreciated.
In the previous answer for Delphi XE10 change line
Result := TStyledSuggestEdit.Create(nil);
to
Result := TStyledSuggestEdit.Create(nil, Model, PresentedControl);
in the function TStyleSuggestEditProxy.CreateReceiver: TObject;
Plus change Data.Key = 'Suggestions' to Data.Key = 'suggestions' in the TStyledSuggestEdit.MMDataChanged
For iOS (I did not check on Android, but should also work) set ControlType of TMemo or TEdit to Platform - this will show T9 autocomplete and check spelling.

Indy 10 Synchronize TIdTCPServer.onExecute with TIdSync

I have a problem to sync the GUI of server. I'm using Delphi 2007 and Indy 10.1.5.
This is my case:
Server send to all connected client a hearbit (this is the message send from server --> "REQ|HeartBit")
Client response to server with "I'm alive" (this is the message send from client --> "ANS|USERNAME|I'm alive"
In onExecute procedure of the TIdTCPServer I want to see the answer of the client in a TlistView of server, so I have done like in this Link
When I start my application with two process client connected (that are runs in my PC) and send a hearbit message to clients, I see in the listview of server this situation:
REQ|HeartBit (send to Client1)
REQ|HeartBit (send to Client2)
ANS|Client2|I'm Alive
ANS|Client2|I'm Alive
two response message from Client2 (!?!?)
Where is my mistake?
Sorry for my poor English.
Thanks
The code of server side is this:
type
TLog = class(TIdSync)
private
FMsg : string;
protected
procedure DoSynchronize; override;
public
constructor Create(const AMsg: String);
//class procedure AddMsg(const AMsg: String);
end;
// procedure that add items in listview of server
procedure WriteListLog(aTimeStamp : TDateTime;strMessaggio: String);
implementation
procedure TLog.DoSynchronize;
begin
WriteListLog(Now,FMsg);
end
procedure TForm1.tsExecute(AContext: TIdContext);
var
Ctx: TMyContext;
tmp : String;
sync : Tlog;
begin
Ctx := TMyContext(AContext);
tmp := Ctx.Connection.IOHandler.ReadLn;
sync := Tlog.Create(tmp);
try
sync.FMsg := tmp;
sync.Synchronize;
finally
Sync.Free;
end;
end;
If I add lockList in OnExecute I have this correct sequence of message
REQ|HeartBit (send to Client1)
REQ|HeartBit (send to Client2)
ANS|Client1|I'm Alive
ANS|Client2|I'm Alive
Is it Correct?
procedure TForm1.tsExecute(AContext: TIdContext);
var
Ctx: TMyContext;
tmp : String;
sync : Tlog;
begin
Ctx := TMyContext(AContext);
tmp := Ctx.Connection.IOHandler.ReadLn;
Ctx.FContextList.LockList;
try
sync := Tlog.Create(tmp);
try
sync.FMsg := tmp;
sync.Synchronize;
finally
Sync.Free;
end;
finally
Ctx.FContextList.UnlockList;
end;
end;
Update
In my project, the listView and WriteListLog() is in the unit FLogMsg, not in the same unit of the IdTCSPServer.
This is how is defined the tlistview in dfm
object ListLog: TListView
Left = 0
Top = 0
Width = 737
Height = 189
Align = alClient
Columns = <
item
Caption = 'Data'
Width = 140
end
item
Caption = 'Da'
end
item
Caption = 'A'
end
item
Caption = 'Tipo'
end
item
Caption = 'Messaggio'
Width = 900
end>
ColumnClick = False
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
FlatScrollBars = True
OwnerData = True
ReadOnly = True
ParentFont = False
TabOrder = 0
ViewStyle = vsReport
OnData = ListLogData
end
Code of unit FlogMsg:
type
TTipoMessaggio = (tmSend,tmReceived,tmSystem);
TDataItem = class
private
FDITimeStamp: TDateTime;
FDIRecipient: String;
FDISender: String;
FDITipo: TTipoMessaggio;
FDIMessaggio: String;
public
property DITimeStamp: TDateTime read FDITimeStamp;
property DISender : String read FDISender;
property DIRecipient : String read FDIRecipient;
property DITipo : TTipoMessaggio read FDITipo;
property DIMessaggio: String read FDIMessaggio;
end;
TfrmLog = class(TForm)
ListLog: TListView;
Panel1: TPanel;
procedure FormCreate(Sender: TObject);
procedure ListLogData(Sender: TObject; Item: TListItem);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FItems: TObjectList;
FActiveItems: TList;
FFilterLogStation: String;
procedure SetFilterLogStation(const Value: String);
public
{ Public declarations }
property FilterLogStation : String read FFilterLogStation write SetFilterLogStation;
end;
procedure WriteListLog(aTimeStamp : TDateTime;
aSender,aRecipient: String;aTipo:TTipoMessaggio;strMessaggio: String);
var
frmLog: TfrmLog;
implementation
{$R *.dfm}
procedure WriteListLog(aTimeStamp : TDateTime;
aSender,aRecipient: String;aTipo:TTipoMessaggio;strMessaggio: String);
var
DataItem: TDataItem;
begin
DataItem := TDataItem.Create;
try
DataItem.FDITimeStamp := aTimeStamp;
DataItem.FDISender := aSender;
DataItem.FDIRecipient := aRecipient;
DataItem.FDITipo := aTipo;
DataItem.FDIMessaggio := strMessaggio;
frmLog.FItems.Add(DataItem);
if (frmLog.FilterLogStation = '') or (frmLog.FilterLogStation = aRecipient) or
(frmLog.FilterLogStation = aSender) then
begin
frmLog.FActiveItems.Add(DataItem);
frmLog.ListLog.AddItem('',DataItem);
end;
except
DataItem.Free;
raise;
end;
frmLog.ListLog.Repaint;
end;
procedure TfrmLog.FormCreate(Sender: TObject);
begin
FFilterLogStation := '';
FItems := TObjectList.Create;
FActiveItems := TList.Create;
end;
procedure TfrmLog.FormDestroy(Sender: TObject);
begin
FActiveItems.clear;
FreeAndNil(FActiveItems);
FreeAndNil(FItems);
end;
procedure TfrmLog.ListLogData(Sender: TObject; Item: TListItem);
var
DataItem: TDataItem;
begin
DataItem := FActiveItems[Item.Index];
Item.Caption := FormatDateTime('dd/mm/yyy hh.nn.ss', DataItem.DITimeStamp);
Item.SubItems.Add(DataItem.DISender);
Item.SubItems.Add(DataItem.DIRecipient);
// Tipo Messaggio
case DataItem.DITipo of
tmSend: Item.SubItems.Add('Inviato');
tmReceived: Item.SubItems.Add('Ricevuto');
tmSystem: Item.SubItems.Add('Sistema');
end;
Item.SubItems.Add(DataItem.DIMessaggio);
Item.MakeVisible(true);
end;
procedure TfrmLog.SetFilterLogStation(const Value: String);
var
I: Integer;
begin
FFilterLogStation := Value;
ListLog.Items.BeginUpdate;
try
ListLog.Clear;
FActiveItems.Clear;
for I := 0 to FItems.Count - 1 do
if (CompareText(UpperCase(FFilterLogStation),UpperCase(TDataItem(FItems[I]).DISender)) = 0) or
(CompareText(UpperCase(FFilterLogStation),UpperCase(TDataItem(FItems[I]).DIRecipient)) = 0)
or (FFilterLogStation = '') then
begin
FActiveItems.Add(FItems[I]);
end;
ListLog.Items.Count := FActiveItems.Count;
finally
ListLog.Items.EndUpdate;
ListLog.Repaint;
end;
end;
procedure TfrmLog.FormDestroy(Sender: TObject);
begin
FActiveItems.clear;
FreeAndNil(FActiveItems);
FreeAndNil(FItems);
end;
UPDATE 2 - Try with TMemo
this is the result:
(First SendBroadCast HeartBit)
ANS|CARICO1|I'm Alive
ANS|CARICO2|I'm Alive
(Second SendBroadCast HeartBit)
ANS|CARICO1|I'm Alive
ANS|CARICO2|I'm Alive
(Third SendBroadCast HeartBit)
ANS|CARICO1|I'm Alive
ANS|CARICO1|I'm Alive
I add a TStringList variable in my TMyContext class.
In debug session, for each Context, if I inspect the queue of message that is saved on my TStringList variable the messages are correct!
So, I think that the problem is in Synchronize...
type
TTipoStazione = (tsNone,tsCarico,tsScarico);
TLog = class(TIdSync)
private
FMsg : string;
FFrom : String;
protected
procedure DoSynchronize; override;
public
end;
TMyContext = class(TIdContext)
public
IP: String;
UserName: String;
Stazione : Integer;
tipStaz : TTipoStazione;
Con: TDateTime;
isValid : Boolean;
ls : TStringList;
// compname:string;
procedure ProcessMsg;
end;
TForm1 = class(TForm)
ts: TIdTCPServer;
Memo1: TMemo;
btconnect: TButton;
edport: TEdit;
Button2: TButton;
procedure btconnectClick(Sender: TObject);
procedure tsConnect(AContext: TIdContext);
procedure tsExecute(AContext: TIdContext);
procedure tsDisconnect(AContext: TIdContext);
constructor Create(AOwner: TComponent);override;
procedure FormDestroy(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
procedure SendMsgBroadcast(aMsg : String);
public
{ Public declarations }
procedure MyWriteListLog(strMessaggio : String);
end;
implementation
constructor TLog.Create(const aFrom: String; const AMsg: String);
begin
inherited Create;
FMsg := AMsg;
FFrom := aFrom;
end;
procedure TLog.DoSynchronize;
begin
Form1.MyWriteListLog(FMsg);
end;
procedure TMyContext.ProcessMsg;
var
str,TypeMsg:string;
myTLog: TLog;
begin
if Connection.IOHandler.InputBufferIsEmpty then
exit;
str:=self.Connection.IOHandler.ReadLn;
ls.Add('1='+str);
myTLog := Tlog.Create;
try
myTLog.FMsg := str;
myTLog.FFrom := UserName;
myTLog.Synchronize;
ls.Add('2='+str);
finally
myTLog.Free;
end;
end;
constructor TForm1.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ts.ContextClass := TMyContext;
DMVern := TDMVern.Create(nil);
end;
procedure TForm1.btconnectClick(Sender: TObject);
begin
ts.DefaultPort:=strtoint(edport.Text);
ts.Active:=true;
MyWriteListLog('Listening');
end;
procedure TForm1.tsConnect(AContext: TIdContext);
var
strErr : String;
I: Integer;
tmpNrStaz: String;
tmpMsg : String;
begin
strErr := '';
ts.Contexts.LockList;
try
with TMyContext(AContext) do
begin
ls := TStringList.Create;
isValid := false;
Con := Now;
if (Connection.Socket <> nil) then
IP :=Connection.Socket.Binding.PeerIP;
tmpMsg := Connection.IOHandler.ReadLn;
try
if not (Pos('START|',tmpMsg) > 0) then
begin
strErr := 'Comando non valido';
exit;
end;
UserName := Copy(tmpMsg,Length('START|')+1,Length(tmpMsg));
if Trim(UserName) = '' then
begin
strErr := 'How Are You?';
exit;
end;
tipStaz := tsNone;
if UpperCase(Copy(UserName,1,6)) = 'CARICO' then
tipStaz := tsCarico
else if UpperCase(Copy(UserName,1,7)) = 'SCARICO' then
tipStaz := tsCarico;
if tipStaz = tsNone then
begin
strErr := 'Tipo Stazione non valida.';
exit;
end;
tmpNrStaz := '';
for I := Length(UserName) downto 1 do
begin
if (UserName[i] in ['0'..'9']) then
tmpNrStaz:= UserName[i] + tmpNrStaz
else if tmpNrStaz <> '' then
break;
end;
if tmpNrStaz = '' then
begin
strErr := 'Numero Stazione non specificato.';
exit;
end;
Stazione := StrToInt(tmpNrStaz);
isValid := true;
tmpMsg := 'HELLO|' + UserName;
Connection.IOHandler.WriteLn(tmpMsg);
finally
if strErr <> '' then
begin
Connection.IOHandler.WriteLn(strErr);
Connection.Disconnect;
end;
end;
end;
finally
ts.Contexts.UnlockList;
end;
end;
procedure TForm1.tsExecute(AContext: TIdContext);
var
Ctx: TMyContext;
tmp : String;
begin
Ctx := TMyContext(AContext);
Ctx.ProcessMsg;
end;
procedure TForm1.tsDisconnect(AContext: TIdContext);
begin
TMyContext(AContext).ProcessMsg;
end;
procedure TForm1.MyWriteListLog(strMessaggio: String);
begin
Memo1.Lines.Add(strMessaggio);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
aMsg: String;
begin
aMsg := 'REQ|HeartBit';
SendMsgBroadcast(aMsg);
end;
procedure TForm1.SendMsgBroadcast(aMsg: String);
var
List: TList;
I: Integer;
Context: TMyContext;
begin
List := ts.Contexts.LockList;
try
for I := 0 to List.Count-1 do
begin
Context := TMyContext(List[I]);
if Context.isValid then
begin
try
Context.Connection.IOHandler.WriteLn(aMsg);
except
end;
end;
end;
finally
ts.Contexts.UnlockList;
end;
end;
You are using a virtual ListView, but I see two mistakes you are making with it:
You are calling AddItem() and Clear() on it. Do not do that. The whole point of a virtual ListView is to not put any real data in it at all. After you add or remove objects in your FActiveItems list, all you have to do is update the TListView.Items.Count property to reflect the new item count. It will invalidate itself by default to trigger a repaint (but if you want to trigger a repaint manually, use Invalidate() instead of Repaint(), and call it only when you have done something to modify FActiveItems).
Your OnData handler is calling TListItem.MakeVisible(). That call does not belong in that event, it belongs in WriteListLog() instead. OnData triggered whenever the ListView needs data for an item for any reason, including during drawing. Don't perform any UI management operations in a data management event.
Try this instead:
procedure WriteListLog(aTimeStamp : TDateTime;
aSender,aRecipient: String;aTipo:TTipoMessaggio;strMessaggio: String);
var
DataItem: TDataItem;
Index, ActiveIndex: Integer;
begin
DataItem := TDataItem.Create;
try
DataItem.FDITimeStamp := aTimeStamp;
DataItem.FDISender := aSender;
DataItem.FDIRecipient := aRecipient;
DataItem.FDITipo := aTipo;
DataItem.FDIMessaggio := strMessaggio;
Index := frmLog.FItems.Add(DataItem);
try
if (frmLog.FilterLogStation = '') or
AnsiSameText(frmLog.FilterLogStation, aRecipient) or
AnsiSameText(frmLog.FilterLogStation, aSender) then
begin
ActiveIndex := frmLog.FActiveItems.Add(DataItem);
frmLog.ListLog.Items.Count := frmLog.FActiveItems.Count;
frmLog.Items[ActiveIndex].MakeVisible(true);
end;
except
frmLog.FItems.Delete(Index);
DataItem := nil;
raise;
end;
except
DataItem.Free;
raise;
end;
end;
procedure TfrmLog.FormCreate(Sender: TObject);
begin
FFilterLogStation := '';
FItems := TObjectList.Create(True);
FActiveItems := TList.Create;
end;
procedure TfrmLog.FormDestroy(Sender: TObject);
begin
FItems.Free;
FActiveItems.Free;
end;
procedure TfrmLog.ListLogData(Sender: TObject; Item: TListItem);
var
DataItem: TDataItem;
begin
DataItem := TDataItem(FActiveItems[Item.Index]);
Item.Caption := FormatDateTime('dd/mm/yyy hh.nn.ss', DataItem.DITimeStamp);
Item.SubItems.Add(DataItem.DISender);
Item.SubItems.Add(DataItem.DIRecipient);
// Tipo Messaggio
case DataItem.DITipo of
tmSend: Item.SubItems.Add('Inviato');
tmReceived: Item.SubItems.Add('Ricevuto');
tmSystem: Item.SubItems.Add('Sistema');
else
Item.SubItems.add('');
end;
Item.SubItems.Add(DataItem.DIMessaggio);
end;
procedure TfrmLog.SetFilterLogStation(const Value: String);
var
I: Integer;
DataItem: TDataItem;
begin
if FFilterLogStation = Value then Exit;
ListLog.Items.Count := 0;
FActiveItems.Clear;
FFilterLogStation := Value;
try
for I := 0 to FItems.Count - 1 do
begin
DataItem := TDataItem(FItems[I]);
if (FFilterLogStation = '') or
AnsiSameText(FFilterLogStation, DataItem.DISender) or
AnsiSameText(FFilterLogStation), DataItem.DIRecipient) then
begin
FActiveItems.Add(DataItem);
end;
end;
finally
ListLog.Items.Count := FActiveItems.Count;
end;
end;

Custom Control Creation in Delphi

I used this on a form and created it like 10 times. That was ok, until I tried to pass this number. Then it started eating system resources. Is there any way I could create a component like this? It is for a Simulator project, 8bits needed to indicate the value of the register in binary.
any help, comments, ideas are really appreciated.
ty.
I was slightly bored, and I wanted to play with my new Delphi XE, so I've made a component for you. It should work in older Delphi's just fine.
You can download it here: BitEditSample.zip
How does it work?
It inherits from customcontrol, so you can focus the component.
It contains an array of labels and checkboxes.
The bit number is stored in the "tag" property of each checkbox
Each checkbox gets an onchange handler that reads the tag, to see which bit needs to be manipulated.
How to use it
It has a property "value". If you change it, the checkboxes will update.
If you click the checkboxes, the value will change.
Set the property "caption" to change the text that says "Register X:"
You can create an "onchange" event handler, so that when the value changes (because of a mouseclick for example), you'll be notified.
The zipfile contains a component, a package, and a sample application (including a compiled exe, so you can try it out quickly).
unit BitEdit;
interface
uses
SysUtils, Classes, Controls, StdCtrls, ExtCtrls;
type
TBitEdit = class(TCustomControl)
private
FValue : Byte; // store the byte value internally
FBitLabels : Array[0..7] of TLabel; // the 7 6 5 4 3 2 1 0 labels
FBitCheckboxes : Array[0..7] of TCheckBox;
FCaptionLabel : TLabel;
FOnChange : TNotifyEvent;
function GetValue: byte;
procedure SetValue(const aValue: byte);
procedure SetCaption(const aValue: TCaption);
procedure SetOnChange(const aValue: TNotifyEvent);
function GetCaption: TCaption;
{ Private declarations }
protected
{ Protected declarations }
procedure DoBitCheckboxClick(Sender:TObject);
procedure UpdateGUI;
procedure DoOnChange;
public
constructor Create(AOwner: TComponent); override;
{ Public declarations }
published
property Value:byte read GetValue write SetValue;
property Caption:TCaption read GetCaption write SetCaption;
property OnChange:TNotifyEvent read FOnChange write SetOnChange;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TBitEdit]);
end;
{ TBitEdit }
constructor TBitEdit.Create(AOwner: TComponent);
var
I:Integer;
begin
inherited;
Width := 193;
Height := 33;
FCaptionLabel := TLabel.Create(self);
FCaptionLabel.Left := 0;
FCaptionLabel.Top := 10;
FCaptionLabel.Caption := 'Register X :';
FCaptionLabel.Width := 60;
FCaptionLabel.Parent := self;
FCaptionLabel.Show;
for I := 0 to 7 do
begin
FBitCheckboxes[I] := TCheckBox.Create(self);
FBitCheckboxes[I].Parent := self;
FBitCheckboxes[I].Left := 5 + FCaptionLabel.Width + (16 * I);
FBitCheckboxes[I].Top := 14;
FBitCheckboxes[I].Caption := '';
FBitCheckboxes[I].Tag := 7-I;
FBitCheckboxes[I].Hint := 'bit ' + IntToStr(FBitCheckboxes[I].Tag);
FBitCheckboxes[I].OnClick := DoBitCheckboxClick;
end;
for I := 0 to 7 do
begin
FBitLabels[I] := TLabel.Create(Self);
FBitLabels[I].Parent := self;
FBitLabels[I].Left := 8 + FCaptionLabel.Width + (16 * I);
FBitLabels[I].Top := 0;
FBitLabels[I].Caption := '';
FBitLabels[I].Tag := 7-I;
FBitLabels[I].Hint := 'bit ' + IntToStr(FBitLabels[I].Tag);
FBitLabels[I].Caption := IntToStr(FBitLabels[I].Tag);
FBitLabels[I].OnClick := DoBitCheckboxClick;
end;
end;
procedure TBitEdit.DoBitCheckboxClick(Sender: TObject);
var
LCheckbox:TCheckbox;
FOldValue:Byte;
begin
if not (Sender is TCheckBox) then
Exit;
FOldValue := FValue;
LCheckbox := Sender as TCheckbox;
FValue := FValue XOR (1 shl LCheckbox.Tag);
if FOldValue <> FValue then
DoOnChange;
end;
procedure TBitEdit.DoOnChange;
begin
if Assigned(FOnChange) then
FOnChange(Self);
end;
function TBitEdit.GetCaption: TCaption;
begin
Result := FCaptionLabel.Caption;
end;
function TBitEdit.GetValue: byte;
begin
Result := FValue;
end;
procedure TBitEdit.SetCaption(const aValue: TCaption);
begin
FCaptionLabel.Caption := aValue;
end;
procedure TBitEdit.SetOnChange(const aValue: TNotifyEvent);
begin
FOnChange := aValue;
end;
procedure TBitEdit.SetValue(const aValue: byte);
begin
if aValue=FValue then
Exit;
FValue := aValue;
DoOnChange;
UpdateGUI;
end;
procedure TBitEdit.UpdateGUI;
var
I:Integer;
begin
for I := 0 to 7 do
FBitCheckboxes[I].Checked := FValue shr FBitCheckboxes[I].Tag mod 2 = 1;
end;
end.
Resources
I guess the problem that the OP was facing is a feedback loop, where two event handlers call each other.
Other resources don't seem to increase in an unusual way when using more bit editors. I've tested it with an application with many instances of the bit edit component:
[MANY] | [1]
-------------------------+--------------
#Handles |
User : 314 | 35
GDI : 57 | 57
System : 385 | 385
#Memory |
Physical : 8264K | 7740K
Virtual : 3500K | 3482K
#CPU |
Kernel time: 0:00:00.468 | 0:00:00.125
User time : 0:00:00.109 | 0:00:00.062
I agree that there shouldn't be a problem with a hundred checkboxes on a form. But for fun's sake, I just wrote a component that does all drawing manually, so there is only one window handle per control (that is, per eight checkboxes). My control works both with visual themes enabled and with themes disabled. It is also double-buffered, and completely flicker-free.
unit ByteEditor;
interface
uses
Windows, SysUtils, Classes, Messages, Controls, Graphics, Themes, UxTheme;
type
TWinControlCracker = class(TWinControl); // because necessary method SelectNext is protected...
TByteEditor = class(TCustomControl)
private
{ Private declarations }
FTextLabel: TCaption;
FBuffer: TBitmap;
FValue: byte;
CheckboxRect: array[0..7] of TRect;
LabelRect: array[0..7] of TRect;
FSpacing: integer;
FVerticalSpacing: integer;
FLabelSpacing: integer;
FLabelWidth, FLabelHeight: integer;
FShowHex: boolean;
FHexPrefix: string;
FMouseHoverIndex: integer;
FKeyboardFocusIndex: integer;
FOnChange: TNotifyEvent;
FManualLabelWidth: integer;
FAutoLabelSize: boolean;
FLabelAlignment: TAlignment;
procedure SetTextLabel(const TextLabel: TCaption);
procedure SetValue(const Value: byte);
procedure SetSpacing(const Spacing: integer);
procedure SetVerticalSpacing(const VerticalSpacing: integer);
procedure SetLabelSpacing(const LabelSpacing: integer);
procedure SetShowHex(const ShowHex: boolean);
procedure SetHexPrefix(const HexPrefix: string);
procedure SetManualLabelWidth(const ManualLabelWidth: integer);
procedure SetAutoLabelSize(const AutoLabelSize: boolean);
procedure SetLabelAlignment(const LabelAlignment: TAlignment);
procedure UpdateMetrics;
protected
{ Protected declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
procedure WndProc(var Msg: TMessage); override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
public
{ Public declarations }
published
{ Published declarations }
property Color;
property LabelAlignment: TAlignment read FLabelAlignment write SetLabelAlignment default taRightJustify;
property AutoLabelSize: boolean read FAutoLabelSize write SetAutoLabelSize default true;
property ManualLabelWidth: integer read FManualLabelWidth write SetManualLabelWidth default 64;
property TextLabel: TCaption read FTextLabel write SetTextLabel;
property Value: byte read FValue write SetValue default 0;
property Spacing: integer read FSpacing write SetSpacing default 3;
property VerticalSpacing: integer read FVerticalSpacing write SetVerticalSpacing default 3;
property LabelSpacing: integer read FLabelSpacing write SetLabelSpacing default 8;
property ShowHex: boolean read FShowHex write SetShowHex default false;
property HexPrefix: string read FHexPrefix write SetHexPrefix;
property TabOrder;
property TabStop;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
procedure Register;
implementation
const
PowersOfTwo: array[0..7] of byte = (1, 2, 4, 8, 16, 32, 64, 128); // PowersOfTwo[n] := 2^n
BasicCheckbox: TThemedElementDetails = (Element: teButton; Part: BP_CHECKBOX; State: CBS_UNCHECKEDNORMAL);
procedure Register;
begin
RegisterComponents('Rejbrand 2009', [TByteEditor]);
end;
function IsIntInInterval(x, xmin, xmax: integer): boolean; inline;
begin
IsIntInInterval := (xmin <= x) and (x <= xmax);
end;
function PointInRect(const Point: TPoint; const Rect: TRect): boolean; inline;
begin
PointInRect := IsIntInInterval(Point.X, Rect.Left, Rect.Right) and
IsIntInInterval(Point.Y, Rect.Top, Rect.Bottom);
end;
function GrowRect(const Rect: TRect): TRect;
begin
result.Left := Rect.Left - 1;
result.Top := Rect.Top - 1;
result.Right := Rect.Right + 1;
result.Bottom := Rect.Bottom + 1;
end;
{ TByteEditor }
constructor TByteEditor.Create(AOwner: TComponent);
begin
inherited;
FLabelAlignment := taRightJustify;
FManualLabelWidth := 64;
FAutoLabelSize := true;
FTextLabel := 'Register:';
FValue := 0;
FSpacing := 3;
FVerticalSpacing := 3;
FLabelSpacing := 8;
FMouseHoverIndex := -1;
FKeyboardFocusIndex := 7;
FHexPrefix := '$';
FShowHex := false;
FBuffer := TBitmap.Create;
end;
destructor TByteEditor.Destroy;
begin
FBuffer.Free;
inherited;
end;
procedure TByteEditor.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_TAB:
if TabStop then
begin
if ssShift in Shift then
if FKeyboardFocusIndex = 7 then
TWinControlCracker(Parent).SelectNext(Self, false, true)
else
inc(FKeyboardFocusIndex)
else
if FKeyboardFocusIndex = 0 then
TWinControlCracker(Parent).SelectNext(Self, true, true)
else
dec(FKeyboardFocusIndex);
Paint;
end;
VK_SPACE:
SetValue(FValue xor PowersOfTwo[FKeyboardFocusIndex]);
end;
end;
procedure TByteEditor.KeyUp(var Key: Word; Shift: TShiftState);
begin
inherited;
end;
procedure TByteEditor.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if TabStop then SetFocus;
FKeyboardFocusIndex := FMouseHoverIndex;
Paint;
end;
procedure TByteEditor.MouseMove(Shift: TShiftState; X, Y: Integer);
var
i: Integer;
OldIndex: integer;
begin
inherited;
OldIndex := FMouseHoverIndex;
FMouseHoverIndex := -1;
for i := 0 to 7 do
if PointInRect(point(X, Y), CheckboxRect[i]) then
begin
FMouseHoverIndex := i;
break;
end;
if FMouseHoverIndex <> OldIndex then
Paint;
end;
procedure TByteEditor.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
Paint;
if (FMouseHoverIndex <> -1) and (Button = mbLeft) then
begin
SetValue(FValue xor PowersOfTwo[FMouseHoverIndex]);
if Assigned(FOnChange) then
FOnChange(Self);
end;
end;
const
DTAlign: array[TAlignment] of cardinal = (DT_LEFT, DT_RIGHT, DT_CENTER);
procedure TByteEditor.Paint;
var
details: TThemedElementDetails;
i: Integer;
TextRect: TRect;
HexStr: string;
begin
inherited;
FBuffer.Canvas.Brush.Color := Color;
FBuffer.Canvas.FillRect(ClientRect);
TextRect := Rect(0, 0, FLabelWidth, Height);
DrawText(FBuffer.Canvas.Handle, FTextLabel, length(FTextLabel), TextRect,
DT_SINGLELINE or DT_VCENTER or DTAlign[FLabelAlignment] or DT_NOCLIP);
for i := 0 to 7 do
begin
if ThemeServices.ThemesEnabled then
with details do
begin
Element := teButton;
Part := BP_CHECKBOX;
if FMouseHoverIndex = i then
if csLButtonDown in ControlState then
if FValue and PowersOfTwo[i] <> 0 then
State := CBS_CHECKEDPRESSED
else
State := CBS_UNCHECKEDPRESSED
else
if FValue and PowersOfTwo[i] <> 0 then
State := CBS_CHECKEDHOT
else
State := CBS_UNCHECKEDHOT
else
if FValue and PowersOfTwo[i] <> 0 then
State := CBS_CHECKEDNORMAL
else
State := CBS_UNCHECKEDNORMAL;
ThemeServices.DrawElement(FBuffer.Canvas.Handle, details, CheckboxRect[i]);
end
else
begin
if FMouseHoverIndex = i then
if csLButtonDown in ControlState then
if FValue and PowersOfTwo[i] <> 0 then
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_PUSHED)
else
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_PUSHED)
else
if FValue and PowersOfTwo[i] <> 0 then
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_HOT)
else
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_HOT)
else
if FValue and PowersOfTwo[i] <> 0 then
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_CHECKED)
else
DrawFrameControl(FBuffer.Canvas.Handle, CheckboxRect[i], DFC_BUTTON, DFCS_BUTTONCHECK)
end;
TextRect := LabelRect[i];
DrawText(FBuffer.Canvas.Handle, IntToStr(i), 1, TextRect, DT_SINGLELINE or DT_TOP or DT_CENTER or DT_NOCLIP);
end;
if Focused then
DrawFocusRect(FBuffer.Canvas.Handle, GrowRect(CheckboxRect[FKeyboardFocusIndex]));
if FShowHex then
begin
TextRect.Left := CheckboxRect[7].Left;
TextRect.Right := CheckboxRect[0].Right;
TextRect.Top := CheckboxRect[7].Bottom + FVerticalSpacing;
TextRect.Bottom := TextRect.Top + FLabelHeight;
HexStr := 'Value = ' + IntToStr(FValue) + ' (' + FHexPrefix + IntToHex(FValue, 2) + ')';
DrawText(FBuffer.Canvas.Handle, HexStr, length(HexStr), TextRect,
DT_SINGLELINE or DT_CENTER or DT_NOCLIP);
end;
BitBlt(Canvas.Handle, 0, 0, Width, Height, FBuffer.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TByteEditor.SetShowHex(const ShowHex: boolean);
begin
if ShowHex <> FShowHex then
begin
FShowHex := ShowHex;
Paint;
end;
end;
procedure TByteEditor.SetSpacing(const Spacing: integer);
begin
if Spacing <> FSpacing then
begin
FSpacing := Spacing;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetVerticalSpacing(const VerticalSpacing: integer);
begin
if VerticalSpacing <> FVerticalSpacing then
begin
FVerticalSpacing := VerticalSpacing;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetAutoLabelSize(const AutoLabelSize: boolean);
begin
if FAutoLabelSize <> AutoLabelSize then
begin
FAutoLabelSize := AutoLabelSize;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetHexPrefix(const HexPrefix: string);
begin
if not SameStr(FHexPrefix, HexPrefix) then
begin
FHexPrefix := HexPrefix;
Paint;
end;
end;
procedure TByteEditor.SetLabelAlignment(const LabelAlignment: TAlignment);
begin
if FLabelAlignment <> LabelAlignment then
begin
FLabelAlignment := LabelAlignment;
Paint;
end;
end;
procedure TByteEditor.SetLabelSpacing(const LabelSpacing: integer);
begin
if LabelSpacing <> FLabelSpacing then
begin
FLabelSpacing := LabelSpacing;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetManualLabelWidth(const ManualLabelWidth: integer);
begin
if FManualLabelWidth <> ManualLabelWidth then
begin
FManualLabelWidth := ManualLabelWidth;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetTextLabel(const TextLabel: TCaption);
begin
if not SameStr(TextLabel, FTextLabel) then
begin
FTextLabel := TextLabel;
UpdateMetrics;
Paint;
end;
end;
procedure TByteEditor.SetValue(const Value: byte);
begin
if Value <> FValue then
begin
FValue := Value;
Paint;
end;
end;
procedure TByteEditor.WndProc(var Msg: TMessage);
begin
inherited;
case Msg.Msg of
WM_GETDLGCODE:
Msg.Result := Msg.Result or DLGC_WANTTAB or DLGC_WANTARROWS or DLGC_WANTALLKEYS;
WM_ERASEBKGND:
Msg.Result := 1;
WM_SIZE:
begin
UpdateMetrics;
Paint;
end;
WM_SETFOCUS, WM_KILLFOCUS:
Paint;
end;
end;
procedure TByteEditor.UpdateMetrics;
var
CheckboxWidth, CheckboxHeight: integer;
i: Integer;
begin
FBuffer.SetSize(Width, Height);
FBuffer.Canvas.Font.Assign(Font);
with FBuffer.Canvas.TextExtent(FTextLabel) do
begin
if FAutoLabeLSize then
FLabelWidth := cx
else
FLabelWidth := FManualLabelWidth;
FLabelHeight := cy;
end;
CheckboxWidth := GetSystemMetrics(SM_CXMENUCHECK);
CheckboxHeight := GetSystemMetrics(SM_CYMENUCHECK);
for i := 0 to 7 do
begin
with CheckboxRect[i] do
begin
Left := (FLabelWidth + FLabelSpacing) + (7-i) * (CheckboxWidth + FSpacing);
Right := Left + CheckboxWidth;
Top := (Height - (CheckboxHeight)) div 2;
Bottom := Top + CheckboxHeight;
end;
LabelRect[i].Left := CheckboxRect[i].Left;
LabelRect[i].Right := CheckboxRect[i].Right;
LabelRect[i].Top := CheckboxRect[i].Top - FLabelHeight - FVerticalSpacing;
LabelRect[i].Bottom := CheckboxRect[i].Top;
end;
Width := (FLabelWidth + FLabelSpacing) + 8 * (CheckboxWidth + FSpacing);
end;
end.
Example:
(High-Res)
You have these options, in order of difficulty:
Create a frame, and reuse it
Create a compound control (using
maybe a panel, labels and
checkboxes). Each control will
handle its own keyboard/mouse
interaction.
Create a whole new control - all
elements are drawn using the proper
APIs and all keyboard/mouse
interaction is handled by the
control code.

Filtering data on DBGrid on dbedit keypress

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.

Resources