Delphi FMX TTreeView Argument out of range exception - delphi

Using Delphi 10.4.
I am hoping someone can explain what I am doing wrong with my FMX TTreeView that is causing an EArgumentOutOfRangeException. I am trying to create a custom TTreeViewItem class that allows me to associate some data with each node, as well as provide an in-place editor to allowing changing the node text.
The code below is a stripped down version of what I am doing. The FMX form has a TTreeview and two buttons on it, with the form's Onshow set to FormShow and the buttons set to the two button events.
The TVLinkTreeViewItem is my custom TTreeViewItem where I add a background and edit component for my in-place editor, which is displayed when a node is double clicked.
When you run the code as is, the program will throw the exception when the logic gets to the TreeView1.EndUpdate call at the end of the FormShow routine. The exception is thrown in FMX.Controls in the TControl.EndUpdate procedure.
If you comment out the ExpandAll call, the exception is not thrown, but if you mess with the expanding and collapsing of the nodes and resizing of the form, sooner or later the exception gets thrown. I left the ExpandAll line in the code below, as I assume the exception is being caused by the same error.
From what I can tell, the problem appears to be how I am setting up the fBackground and fEditor. If I don't call the AddObject routine and not set the Parent properties, I get no exception.
So can anybody tell me what I am doing wrong? Or is there a better way to do an in-place editor for the FMX TTreeViewItems component?
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.TreeView, FMX.Layouts, FMX.Controls.Presentation,
FMX.MultiView, FMX.Edit, FMX.Objects, FMX.StdCtrls;
type
TForm1 = class(TForm)
TreeView1: TTreeView;
Button1: TButton;
Button2: TButton;
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
type
TVLinkTreeViewItem = class(TTreeViewItem)
private
fData: string;
fEditor: TEdit;
fBackground: TRectangle;
procedure TreeViewItem1DblClick(Sender: TObject);
procedure EditorExit(Sender: TObject);
procedure EditorKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
public
property Editor: TEdit read fEditor write fEditor;
property Data: string read fData write fData;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TreeView1.ExpandAll;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
TreeView1.CollapseAll;
end;
procedure TForm1.FormShow(Sender: TObject);
var
I, c, r, s: Integer;
vNode1,
vNode2,
vNode3,
vNode4: TVLinkTreeViewItem;
begin
TreeView1.BeginUpdate;
TreeView1.Clear;
for I := 0 to 4 do
begin
vNode1 := TVLinkTreeViewItem.Create(TreeView1);
vNode1.Text := 'Level 1 - '+ IntToStr(I);
TreeView1.AddObject(vNode1);
for c := 0 to 4 do
begin
vNode2 := TVLinkTreeViewItem.Create(vNode1);
vNode2.Text := 'Level 2 - '+ IntToStr(c);
vNode1.AddObject(vNode2);
for r := 0 to 4 do
begin
vNode3 := TVLinkTreeViewItem.Create(vNode2);
vNode3.Text := 'Level 3 - '+ IntToStr(r);
vNode2.AddObject(vNode3);
// for s := 0 to 4 do
// begin
// vNode4 := TVLinkTreeViewItem.Create(vNode3);
// vNode4.Text := 'Level 4 - '+ IntToStr(s);
// vNode3.AddObject(vNode4);
// end;
end;
end;
end;
//ExpandAll works when no parent is set for fBackGround and fEditor is not set in "TVLinkTreeViewItem.Create" below"
//If the Parents are set below, ExpandAll/EndUpdate causes "Augument out of range" exception.
TreeView1.ExpandAll;
treeView1.EndUpdate;
end;
{ TVLinkTreeViewItem }
constructor TVLinkTreeViewItem.Create(AOwner: TComponent);
begin
inherited;
fData := '';
fBackground := TRectangle.Create(AOwner);
//When ExpandAll is not called in FormShow,
// Calling "AddObject" or setting parent, as shown below, make all the code work,
// but will get intermident "Augument out of range" exceptions when resizing form,
// or when expanding or collapsing nodes using the buttons.
self.AddObject(fBackGround);
//fBackGround.Parent := self;
fBackGround.Visible := false;
fEditor := TEdit.Create(AOwner);
fBackGround.AddObject(fEditor);
//fEditor.Parent := fBackGround;
fEditor.Visible := false;
fEditor.Align := TAlignLayout.Client;
fEditor.OnKeyDown := EditorKeyUp;
self.OnDblClick := TreeViewItem1DblClick;
fEditor.OnExit := EditorExit;
end;
destructor TVLinkTreeViewItem.Destroy;
begin
inherited;
end;
procedure TVLinkTreeViewItem.TreeViewItem1DblClick(Sender: TObject);
begin
fBackGround.Visible := true;
fBackGround.Width := self.Width - 20;
fBackGround.Height := self.Height;
fBackGround.Position.X := 20;
fEditor.Enabled := true;
fEditor.Visible := true;
fEditor.Opacity := 1;
fBackGround.BringToFront;
fEditor.BringToFront;
fEditor.Text := Text;
fEditor.SetFocus;
fEditor.SelectAll;
end;
procedure TVLinkTreeViewItem.EditorKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
begin
inherited;
if Key = vkReturn then
begin
Text := fEditor.Text;
fBackGround.Visible := false;
fEditor.Enabled := false;
end
else if Key in [vkEscape, vkCancel, vkTab, vkHardwareBack] then
begin
fBackGround.Visible := false;
fEditor.Enabled := false;
end;
end;
procedure TVLinkTreeViewItem.EditorExit(Sender: TObject);
begin
fBackGround.Visible := false;
fEditor.Enabled := false;
fEditor.Visible := false;
end;
end.
Here's the fmx content:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 480
ClientWidth = 640
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnShow = FormShow
DesignerMasterStyle = 0
object TreeView1: TTreeView
Align = Left
Size.Width = 269.000000000000000000
Size.Height = 480.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
Viewport.Width = 265.000000000000000000
Viewport.Height = 476.000000000000000000
end
object Button1: TButton
Position.X = 356.000000000000000000
Position.Y = 68.000000000000000000
TabOrder = 2
Text = 'Expand'
OnClick = Button1Click
end
object Button2: TButton
Position.X = 354.000000000000000000
Position.Y = 102.000000000000000000
TabOrder = 1
Text = 'Collapse'
OnClick = Button2Click
end
end

Related

Create, destroy and count values inside dynamic controls in Delphi

I have questions about how to create dynamic controls, how destroy and how get value inside newly created control.
Create and count edits create in form worked correctly, but where I create edits in panels with buttons to destroy chosen panel (Panel [Edit, button]), it's create correctly, but count doesnt work.
And I don't know how to destroy chosen by me panel with edit without error (I didn't make it yet in code below).
I have this code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
type
TfrmMain = class(TForm)
btnCreateNewObject: TButton;
btnCountValues: TButton;
btnCreateNewPanels: TButton;
btnAllEditsInPanels: TButton;
procedure btnCreateNewObjectClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btnCountValuesClick(Sender: TObject);
procedure btnCreateNewPanelsClick(Sender: TObject);
procedure btnAllEditsInPanelsClick(Sender: TObject);
private
dynEdit: TEdit;
dynPanel: TPanel;
yposition: integer;
ypositionpanel: integer;
{ Private declarations }
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
procedure TfrmMain.btnCountValuesClick(Sender: TObject);
var
i: integer;
res: integer;
begin
res := 0;
for i := 0 to Self.ControlCount - 1 do
begin
if Controls[i] is TEdit then
begin
res := res + StrToInt((Controls[i] as TEdit).Text);
end;
end;
ShowMessage(IntToStr(res));
end;
procedure TfrmMain.btnCreateNewObjectClick(Sender: TObject);
begin
dynEdit := TEdit.Create(Self);
with dynEdit do
begin
Parent := frmMain;
Width := 80;
Height := 25;
Top := yposition;
Left := 3;
end;
yposition := yposition + 26
end;
procedure TfrmMain.btnCreateNewPanelsClick(Sender: TObject);
begin
dynPanel := TPanel.Create(Self);
with dynPanel do
begin
Parent := frmMain;
Width := 100;
Height := 40;
Top := ypositionpanel;
Left := 120;
dynEdit := TEdit.Create(Self);
with dynEdit do
begin
Parent := dynPanel;
Width := 80;
Height := 25;
Top := 3;
Left := 3;
end;
end;
ypositionpanel := ypositionpanel + 41;
end;
procedure TfrmMain.btnAllEditsInPanelsClick(Sender: TObject);
var
i, j: integer;
res: integer;
begin
res := 0;
for i := 0 to Self.ControlCount - 1 do
begin
for j := 0 to dynPanel.ControlCount - 1 do
begin
if dynPanel.Controls[j] is TEdit then
begin
res := res + StrToInt( (Controls[j] as TEdit).Text );
end;
end;
end;
ShowMessage(IntToStr(res));
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
yposition := 1;
ypositionpanel := 1;
end;
end.
object frmMain: TfrmMain
Left = 0
Top = 0
Caption = 'frmMain'
ClientHeight = 500
ClientWidth = 888
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object btnCreateNewObject: TButton
Left = 775
Top = 475
Width = 113
Height = 25
Caption = 'Create new edit'
TabOrder = 0
OnClick = btnCreateNewObjectClick
end
object btnCountValues: TButton
Left = 775
Top = 444
Width = 113
Height = 25
Caption = 'Count all edits'
TabOrder = 1
OnClick = btnCountValuesClick
end
object btnCreateNewPanels: TButton
Left = 648
Top = 475
Width = 121
Height = 25
Caption = 'Create new panels'
TabOrder = 2
OnClick = btnCreateNewPanelsClick
end
object btnAllEditsInPanels: TButton
Left = 648
Top = 444
Width = 121
Height = 25
Caption = 'Count all edits in panels'
TabOrder = 3
OnClick = btnAllEditsInPanelsClick
end
end
You are iterating only through the Edit controls that are direct children of the Form itself, or of the last Panel created. You are not iterating through all of the Panels.
Use a TList or other suitable container to keep track of the Edits you create dynamically, then you can loop through that list/container when needed. And when you are ready to remove a Panel from the Form, simply Remove() its child TEdit from the list and then Free() the Panel, which will free the TEdit for you.
For example:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls,
System.Generics.Collections;
type
TfrmMain = class(TForm)
btnCreateNewObject: TButton;
btnCountValues: TButton;
btnCreateNewPanels: TButton;
btnAllEditsInPanels: TButton;
procedure btnCreateNewObjectClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnCountValuesClick(Sender: TObject);
procedure btnCreateNewPanelsClick(Sender: TObject);
procedure btnAllEditsInPanelsClick(Sender: TObject);
procedure DestroyPanel(Sender: TObject);
private
{ Private declarations }
AllEdits: TList<TEdit>;
yposition: integer;
ypositionpanel: integer;
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
procedure TfrmMain.btnCountValuesClick(Sender: TObject);
var
i, res: integer;
dynEdit: TEdit;
begin
res := 0;
for i := 0 to AllEdits.Count - 1 do
begin
dynEdit := AllEdits[i];
if dynEdit.Parent = Self then
res := res + StrToInt(dynEdit.Text);
end;
ShowMessage(IntToStr(res));
end;
procedure TfrmMain.btnCreateNewObjectClick(Sender: TObject);
var
dynEdit: TEdit;
begin
dynEdit := TEdit.Create(Self);
try
with dynEdit do
begin
Parent := Self;
Width := 80;
Height := 25;
Top := yposition;
Left := 3;
end;
AllEdits.Add(dynEdit);
except
dynEdit.Free;
raise;
end;
yposition := yposition + 26
end;
procedure TfrmMain.btnCreateNewPanelsClick(Sender: TObject);
var
dynPanel: TPanel;
dynEdit: TEdit;
dynButton: TButton;
begin
dynPanel := TPanel.Create(Self);
try
with dynPanel do
begin
Parent := Self;
Width := 200;
Height := 40;
Top := ypositionpanel;
Left := 120;
end;
dynEdit := TEdit.Create(dynPanel);
with dynEdit do
begin
Parent := dynPanel;
Width := 80;
Height := 25;
Top := 3;
Left := 3;
end;
dynButton := TButton.Create(dynPanel);
with dynButton do
begin
Parent := dynPanel;
Width := 100;
Height := 25;
Top := 3;
Left := 100;
Caption := 'Destroy this pnl';
onClick := DestroyPanel;
end;
AllEdits.Add(dynEdit);
except
dynPanel.Free;
raise;
end;
ypositionpanel := ypositionpanel + 41;
end;
procedure TfrmMain.DestroyPanel(Sender: TObject);
var
dynPanel: TPanel;
dynEdit: TEdit;
begin
dynPanel := TPanel(TButton(Sender).Owner);
dynEdit := TEdit(dynPanel.Controls[0]);
AllEdits.Remove(dynEdit);
dynPanel.Free;
end;
procedure TfrmMain.btnAllEditsInPanelsClick(Sender: TObject);
var
i, res: integer;
dynEdit: TEdit;
begin
res := 0;
for i := 0 to AllEdits.Count - 1 do
begin
dynEdit := AllEdits[i];
if dynEdit.Parent <> Self then
res := res + StrToInt(dynEdit.Text);
end;
ShowMessage(IntToStr(res));
end;
procedure TfrmMain.FormCreate(Sender: TObject);
begin
yposition := 1;
ypositionpanel := 1;
AllEdits := TList<TEdit>.Create;
end;
procedure TfrmMain.FormDestroy(Sender: TObject);
begin
AllEdits.Free;
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.

How to call a method of a TThread object from the main VCL thread?

I use Thread in my code to send SMS.
for Send SMS I use the MCoreComponent Class;
first, override Create function AND create a objSMS1 object,
then call objSMS1.connect() in the Execute Function
constructor ReceiveThread.create;
begin
Inherited Create(True);
objSMS1 := TSMS.Create(nil);
end;
procedure ReceiveThread.Execute();
begin
if Not objSMS1.IsError(true, strMyAppName) then
begin
objSMS1.Connect();
if Not objSMS1.IsError(true, strMyAppName) then
ShowMessage('Connection successful');
end;
while not Terminated do
begin
CoInitialize(nil);
DoShowData;//Recieved Message
end;
end;
these two functions work correctly, Connecting to Module Successfully Done, and check inbox every time.
But I need to send a message. My Send Message Function Is:
procedure ReceiveThread.SendSMS(phoneno, txt: String);
var strSendResult :String;
begin
objSMS1.Validity := Trim('24') + LeftStr('Hour', 1);//Access Violation Error
strSendResult := objSMS1.SendSMS(phoneno, txt, False);
if Not objSMS1.IsError(true, strMyAppName) then
MessageDlg('Message sent!', mtInformation, [mbOK], 0);
end;
When I call the SendSMS Function In Button Click On Main Form, App encounter Access Violation Error. How can I Call Send Message In Thread?
other Setting
var
RTh : ReceiveThread;//Global Var
//Run Tread
RTh := ReceiveThread.Create();
RTh.FreeOnTerminate := True;
//Send Message From Button Click
RTh.SendSMS(Phoneno,Msg);//Access Violation Error
As per the question, the main visible problem is that MessageDlg is called from inside a method of the thread without a synchronized block but the code itself has many other issues and the comments to your question have already pointed you out in the right direction.
The call to DoShowData could be another trouble but the question doesn't give more details about it.
Another strange thing is the recurrent call to CoInitialize. Even though this doesn't represent a big issue since subsequent calls return False, the call has to be balanced by CoUninitialize.
Quoting a comment: "Is SendSMS thread-safe?" you know.
I've tried to put some order in your code - I hope...
The thread uses a list of type TThreadList<TSMSInfo> and treats it like a queue to store and get the SMS to be sent: the list is accessed through its Locklist method in order to avoid concurrent access.
The SMS sent notify is implemented as a custom notify event of type TSMSSentEvent: if assigned the event is triggered in between a synchronized block in order to be executed in the main thread (the VCL thread in a GUI application).
Sleep(1) reduces the CPU charge* when the queue is empty - from 50% to 2% on my PC.
Beware of the objSMS1 object creation and its disposal because where I've put it might be not the right place; also probably you have to call objSMS1.Connect every time the queue is sent and objSMS1.Disconnect - this method should be available - right after that but you should know about it.
The {$DEFINE FAKESMS} compiler directive allowed me to test the app since I don't own any of the MCoreComponent libraries: I've left it as is for testing purposes.
SMSSender.pas unit: the thread class and friends
unit SMSSender;
{.$DEFINE FAKESMS}
interface
uses
System.SysUtils,
System.Classes,
System.Generics.Collections,
Winapi.ActiveX;
const
StrMyAppName = '';
type
{$IFDEF FAKESMS}
TSMS = class
public
Validity: string;
function IsError(a: Boolean; b: string): Boolean;
procedure Connect;
function SendSMS(phoneNo, text: string; bBool: Boolean): string;
constructor Create(AObj: TObject);
end;
{$ENDIF}
TSMSInfo = record
id: Integer;
phoneNo: string;
text: string;
end;
TSMSSentEvent = procedure (Sender: TObject; AId: Integer; AIsError: Boolean; AResult: string) of object;
TSMSSender = class(TThread)
private
FSMSList: TThreadList<TSMSInfo>;
FSentCount: Integer;
function GetQueueCount: Integer;
protected
procedure Execute; override;
public
OnSMSSent: TSMSSentEvent;
procedure AddSMS(const ASMSInfo: TSMSInfo);
constructor Create(CreateSuspended: Boolean = False);
destructor Destroy; override;
property QueueCount: Integer read GetQueueCount;
property SentCount: Integer read FSentCount;
end;
implementation
{$IFDEF FAKESMS}
{ TSMS }
procedure TSMS.Connect;
begin
end;
constructor TSMS.Create(AObj: TObject);
begin
end;
function TSMS.IsError(a: Boolean; b: string): Boolean;
begin
Result := False;
end;
function TSMS.SendSMS(phoneNo, text: string; bBool: Boolean): string;
begin
Result := 'message sent';
Sleep(300);//simulates the SMS sent
end;
{$ENDIF}
{ TReceiveThread }
constructor TSMSSender.Create(CreateSuspended: Boolean);
begin
inherited Create(CreateSuspended);
FSentCount := 0;
FSMSList := TThreadList<TSMSInfo>.Create;
end;
destructor TSMSSender.Destroy;
begin
FSMSList.Free;
inherited;
end;
function TSMSSender.GetQueueCount: Integer;
begin
Result := FSMSList.LockList.Count;
FSMSList.UnlockList;
end;
procedure TSMSSender.AddSMS(const ASMSInfo: TSMSInfo);
begin
FSMSList.Add(ASMSInfo);
end;
procedure TSMSSender.Execute;
var
objSMS1: TSMS;
SMSInfo: TSMSInfo;
strSendResult: string;
lst: TList<TSMSInfo>;
begin
CoInitialize(nil);
try
objSMS1 := TSMS.Create(nil);
try
if objSMS1.IsError(True, StrMyAppName) then
raise Exception.Create('Error Message 1');
objSMS1.Connect;
if objSMS1.IsError(True, StrMyAppName) then
raise Exception.Create('Error Message 2');
objSMS1.Validity := '24H';
while not Terminated do begin
while GetQueueCount > 0 do begin
lst := FSMSList.LockList;
try
SMSInfo := lst.First;
lst.Delete(0);
finally
FSMSList.UnlockList;
end;
//maybe the following has to be synchronized in order to work properly?
//Synchronize(procedure
// begin
strSendResult := objSMS1.SendSMS(SMSInfo.phoneNo, SMSInfo.text, False);
// end);
Inc(FSentCount);
if Assigned(OnSMSSent) then
Synchronize(procedure
begin
OnSMSSent(Self, SMSInfo.id, objSMS1.IsError(true, StrMyAppName), strSendResult);
end);
if Terminated then
Break;
end;
Sleep(1);
end;
finally
objSMS1.Free;
end;
finally
CoUninitialize;
end;
end;
end.
Unit1.pas unit: the form unit
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.UITypes,
SMSSender;
type
TForm1 = class(TForm)
btnAddSMS: TButton;
Memo1: TMemo;
btnTerminate: TButton;
btnStart: TButton;
procedure btnAddSMSClick(Sender: TObject);
procedure btnTerminateClick(Sender: TObject);
procedure btnStartClick(Sender: TObject);
private
{ Private declarations }
FReceiver: TSMSSender;
procedure ReceiverSMSSent(Sender: TObject; AId: Integer; AIsError: Boolean; AResult: string);
procedure ReceiverTerminate(Sender: TObject);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
System.Math;
{$R *.dfm}
procedure TForm1.btnAddSMSClick(Sender: TObject);
var
sms: TSMSInfo;
begin
with sms do begin
id := Random(65535);
phoneNo := '+39' + IntToStr(RandomRange(111111111, 999999999));
text := 'You won nothing at all, as usual';
end;
FReceiver.AddSMS(sms);
end;
procedure TForm1.btnStartClick(Sender: TObject);
begin
Memo1.Lines.Clear;
FReceiver := TSMSSender.Create(True);
FReceiver.FreeOnTerminate := True;
FReceiver.OnSMSSent := ReceiverSMSSent;
FReceiver.OnTerminate := ReceiverTerminate;
FReceiver.Start;
btnStart.Enabled := False;
btnAddSMS.Enabled := True;
btnTerminate.Enabled := True;
end;
procedure TForm1.btnTerminateClick(Sender: TObject);
begin
FReceiver.Terminate;
end;
procedure TForm1.ReceiverSMSSent(Sender: TObject; AId: Integer; AIsError: Boolean;
AResult: string);
begin
Memo1.Lines.Add(Format('id = %d'#9'isError = %s'#9'result = %s', [AId, BoolToStr(AIsError), AResult]));
end;
procedure TForm1.ReceiverTerminate(Sender: TObject);
var
receiver: TSMSSender;
ex: Exception;
begin
btnStart.Enabled := True;
btnAddSMS.Enabled := False;
btnTerminate.Enabled := False;
receiver := TSMSSender(Sender);
ex := Exception(receiver.FatalException);
if Assigned(ex) then begin
MessageDlg(ex.Message, mtError, [mbOK], 0);
Exit;
end;
MessageDlg(Format('Thread %d has finished, %d SMS sent, queue count is %d.', [receiver.ThreadID, receiver.SentCount, receiver.QueueCount]), mtInformation, [mbOK], 0);
end;
end.
Unit1.dfm unit
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 277
ClientWidth = 527
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
DesignSize = (
527
277)
PixelsPerInch = 96
TextHeight = 13
object btnAddSMS: TButton
Left = 440
Top = 209
Width = 75
Height = 25
Anchors = [akRight, akBottom]
Caption = 'Add SMS'
Enabled = False
TabOrder = 0
OnClick = btnAddSMSClick
end
object Memo1: TMemo
Left = 8
Top = 8
Width = 417
Height = 257
Anchors = [akLeft, akTop, akRight, akBottom]
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Lucida Console'
Font.Style = []
Lines.Strings = (
'Memo1')
ParentFont = False
ScrollBars = ssVertical
TabOrder = 1
end
object btnTerminate: TButton
Left = 440
Top = 240
Width = 75
Height = 25
Anchors = [akRight, akBottom]
Caption = 'Terminate'
Enabled = False
TabOrder = 2
OnClick = btnTerminateClick
end
object btnStart: TButton
Left = 440
Top = 178
Width = 75
Height = 25
Anchors = [akRight, akBottom]
Caption = 'Start'
TabOrder = 3
OnClick = btnStartClick
end
end
* Why Sleep(1) is better than Sleep(0)

Allow multiple child controls to detect when their parent control resizes

I'm writing a TSplitter descendant that proportionally resizes its aligned control when its parent control resizes. In order to detect the parent resize I subclass the parents WinProc procedure
FOldWindowProc := Parent.WindowProc;
Parent.WindowProc := SubclassedParentWndProc;
This works perfectly when there is a single splitter parented by the parent. However, when there are one or more splitters, only one of them works correctly.
How can I receive a notification to all the splitter controls that the parent has resized?
Here's my code
unit ProportionalSplitterU;
interface
uses
Windows, SysUtils, Controls, Messages, Classes, CommCtrl, ExtCtrls;
type
TSPlitterHelper = class helper for TSplitter
public
function FindControlEx: TControl;
end;
TProportionalSplitter = class(TSplitter)
private
FOldWindowProc: TWndMethod;
FControlRatio: Double;
FProportionalResize: Boolean;
procedure SubclassedParentWndProc(var Msg: TMessage);
procedure SetRatio;
procedure SetProportionalResize(const Value: Boolean);
protected
procedure SetParent(AParent: TWinControl); override;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure StopSizing; override;
public
constructor Create(AOwner: TComponent); override;
published
property ProportionalResize: Boolean read FProportionalResize write SetProportionalResize;
end;
implementation
{ TProportionalSplitter }
constructor TProportionalSplitter.Create(AOwner: TComponent);
begin
inherited;
FProportionalResize := True;
end;
procedure TProportionalSplitter.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if (Operation = opRemove) and
(AComponent = Parent) then
begin
Parent.WindowProc := FOldWindowProc;
FOldWindowProc := nil;
end;
end;
procedure TProportionalSplitter.SetParent(AParent: TWinControl);
begin
FControlRatio := -1;
if Assigned(Parent) then
begin
Parent.WindowProc := FOldWindowProc;
end;
inherited SetParent(AParent);
if Assigned(AParent) then
begin
FOldWindowProc := Parent.WindowProc;
Parent.WindowProc := SubclassedParentWndProc;
SetRatio;
end;
end;
procedure TProportionalSplitter.SetProportionalResize(const Value: Boolean);
begin
FProportionalResize := Value;
SetRatio;
end;
procedure TProportionalSplitter.SetRatio;
var
ActiveControl: TControl;
begin
if FProportionalResize then
begin
ActiveControl := FindControlEx;
if (Parent <> nil) and
(ActiveControl <> nil) then
begin
case Align of
alTop,
alBottom: FControlRatio := ActiveControl.Height / Parent.Height;
alLeft,
alRight: FControlRatio := ActiveControl.Width / Parent.Width;
end;
end;
end
else
begin
FControlRatio := -1;
end;
end;
procedure TProportionalSplitter.StopSizing;
begin
inherited;
SetRatio;
end;
procedure TProportionalSplitter.SubclassedParentWndProc(Var Msg: TMessage);
begin
FOldWindowProc(Msg);
if Msg.Msg = WM_SIZE then
begin
if FControlRatio <> -1 then
begin
case Align of
alTop,
alBottom: FindControlEx.Width := Round(Parent.Height * FControlRatio);
alLeft,
alRight: FindControlEx.Width := Round(Parent.Width * FControlRatio);
end;
end
else
begin
SetRatio;
end;
end;
end;
{ TSPlitterHelper }
function TSPlitterHelper.FindControlEx: TControl;
begin
Result := Self.FindControl;
end;
end.
Demo .pas
unit Unit2;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls,
ProportionalSplitterU;
type
TForm2 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
procedure FormCreate(Sender: TObject);
private
FSplitter: TProportionalSplitter;
FSplitter2: TProportionalSplitter;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
procedure TForm2.FormCreate(Sender: TObject);
begin
FSplitter := TProportionalSplitter.Create(Self);
FSplitter.Parent := Self;
FSplitter.Align := alLeft;
FSplitter.Left := Panel1.Width + 1;
FSplitter.Width := 20;
FSplitter.ResizeStyle := rsUpdate;
FSplitter2 := TProportionalSplitter.Create(Self);
FSplitter2.Parent := Self;
FSplitter2.Align := alTop;
FSplitter2.Top := Panel3.Height + 1;
FSplitter2.Height := 20;
FSplitter2.ResizeStyle := rsUpdate;
end;
end.
Demo .dfm
object Form2: TForm2
Left = 0
Top = 0
Caption = 'Form2'
ClientHeight = 478
ClientWidth = 674
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 120
TextHeight = 16
object Panel1: TPanel
Left = 0
Top = 193
Width = 249
Height = 285
Align = alLeft
Caption = 'Panel1'
TabOrder = 0
ExplicitTop = 0
ExplicitHeight = 478
end
object Panel2: TPanel
Left = 249
Top = 193
Width = 425
Height = 285
Align = alClient
Caption = 'Panel2'
TabOrder = 1
ExplicitTop = 0
ExplicitHeight = 478
end
object Panel3: TPanel
Left = 0
Top = 0
Width = 674
Height = 193
Align = alTop
Caption = 'Panel3'
TabOrder = 2
end
end
You code is working perfectly correctly as far as intercepting parent window messages is concerned. There is however a problem in your window hook code which may have lead you to incorrectly conclude that this was not working as one of your panels in your test case was not being proportionally resized.
The problem is in this code:
case Align of
alTop, vvvvv
alBottom : FindControlEx.Width := Round(Parent.Height * FControlRatio);
^^^^^
alLeft,
alRight : FindControlEx.Width := Round(Parent.Width * FControlRatio);
end;
Notice that in both cases you are setting the WIDTH of the active control. For Top/Bottom aligned splitter you should instead be setting the HEIGHT.
case Align of
alTop, vvvvvv
alBottom : FindControlEx.Height := Round(Parent.Height * FControlRatio);
^^^^^^
alLeft,
alRight : FindControlEx.Width := Round(Parent.Width * FControlRatio);
end;
This is why your top panel was not resizing its height, even though the WM_SIZE message is being received.

Tricky thing about pointers to animate something in Delphi

So, I don't even know how to write the proper title.
What I want to do is to animate the position of lets say a progressbar.
One could discuss how to do this with timers and loops and so on.
However, I want to be able to do something like this:
ProgressBar1.Position:=Animate(ToValue);
or
Animate(ProgressBar1.Position, ToValue);
Is this possible?
creating a component inherited from an integer didnt work.
I tried number 2 using pointers and made this procedure
procedure TForm1.Animate(ToValue: integer; var Dest: Integer);
begin
Dest:=ToValue;
end;
and it did change the position value internally of the progress bar,
but the progress bar did not change visually.
If anybody has an idea of how to do this it would be great.
Thank you!
If you have a relative new version of Delphi,
this is an animation wrapper around a TTimer using anonymous methods.
type
Animate = class
private
class var fTimer : TTimer;
class var fStartValue : Integer;
class var fEndValue : Integer;
class var fProc : TProc<Integer>;
class Constructor Create;
class Destructor Destroy;
class procedure OnTimer(Sender : TObject);
public
class procedure Run( aProc : TProc<Integer>;
fromValue, ToValue, AnimationDelay : Integer);
end;
class constructor Animate.Create;
begin
fTimer := TTimer.Create(nil);
fTimer.Enabled := false;
fTimer.OnTimer := Animate.OnTimer;
end;
class destructor Animate.Destroy;
begin
fTimer.Free;
end;
class procedure Animate.OnTimer(Sender: TObject);
begin
if Assigned(fProc) then
begin
if (fStartValue <= fEndValue) then
begin
fProc(fStartValue);
Inc(fStartValue);
end
else
fTimer.Enabled := false;
end;
end;
class procedure Animate.Run( aProc: TProc<Integer>;
fromValue, ToValue, AnimationDelay: Integer);
begin
fTimer.Interval := AnimationDelay;
fStartValue := fromValue;
fEndValue := ToValue;
fProc := aProc;
fTimer.Enabled := (fStartValue <= fEndValue);
end;
The Animate class is self initializing and self destructing on application start/stop.
Only one animation process can be active.
Use it this way :
Animate.Run(
procedure( aValue : Integer)
begin
ProgressBar1.Position := aValue;
ProgressBar1.Update;
end,
1,100,5
);
As discussed in comments, the above code use class variables and class functions. Drawback is only one animation can be active.
Here is a more complete animation class, where you can instantiate as many animations you like. Expanded functionallity with possibility to stop/proceed, adding an event when ready, and some more properties.
unit AnimatePlatform;
interface
uses
System.Classes,System.SysUtils,Vcl.ExtCtrls;
type
TAnimate = class
private
fTimer : TTimer;
fLoopIx : Integer;
fEndIx : Integer;
fProc : TProc<Integer>;
fOnReady : TProc<TObject>;
procedure OnTimer(Sender : TObject);
function GetRunning : boolean;
procedure SetReady;
public
Constructor Create;
Destructor Destroy; override;
procedure Run( aProc : TProc<Integer>;
FromValue,ToValue,AnimationDelay : Integer); overload;
procedure Run( aProc : TProc<Integer>;
FromValue,ToValue,AnimationDelay : Integer;
AReadyEvent : TNotifyEvent); overload;
procedure Run( aProc : TProc<Integer>;
FromValue,ToValue,AnimationDelay : Integer;
AReadyEvent: TProc<TObject>); overload;
procedure Stop;
procedure Proceed;
property ActualLoopIx : Integer read fLoopIx write fLoopIx;
property Running : boolean read GetRunning;
property OnReady : TProc<TObject> read fOnReady write fOnReady;
end;
implementation
constructor TAnimate.Create;
begin
Inherited;
fTimer := TTimer.Create(nil);
fTimer.Enabled := false;
fTimer.OnTimer := Self.OnTimer;
fOnReady := nil;
end;
destructor TAnimate.Destroy;
begin
fTimer.Free;
Inherited;
end;
function TAnimate.GetRunning: boolean;
begin
Result := fTimer.Enabled;
end;
procedure TAnimate.OnTimer(Sender: TObject);
begin
if Assigned(fProc) then
begin
if (fLoopIx <= fEndIx) then
begin
fProc(fLoopIx);
Inc(fLoopIx);
end;
if (fLoopIx > fEndIx) then
SetReady;
end
else SetReady;
end;
procedure TAnimate.Proceed;
begin
fTimer.Enabled := true;
end;
procedure TAnimate.Run(aProc: TProc<Integer>; FromValue, ToValue,
AnimationDelay: Integer; AReadyEvent: TNotifyEvent);
begin
Run(aProc,FromValue,ToValue,AnimationDelay);
fOnReady := AReadyEvent;
end;
procedure TAnimate.Run(aProc: TProc<Integer>; FromValue, ToValue,
AnimationDelay: Integer; AReadyEvent: TProc<TObject>);
begin
Run(aProc,FromValue,ToValue,AnimationDelay);
fOnReady := AReadyEvent;
end;
procedure TAnimate.Run(aProc: TProc<Integer>; fromValue, ToValue,
AnimationDelay: Integer);
begin
fTimer.Interval := AnimationDelay;
fLoopIx := fromValue;
fEndIx := ToValue;
fProc := aProc;
fTimer.Enabled := true;
end;
procedure TAnimate.SetReady;
begin
Stop;
if Assigned(fOnReady) then
fOnReady(Self);
end;
procedure TAnimate.Stop;
begin
fTimer.Enabled := false;
end;
end.
Update:
Instead of a TTimer based animator, here is a version using an anonymous thread:
uses
SyncObjs;
procedure AnimatedThread( aProc: TProc<Integer>;
FromValue, ToValue, AnimationDelay: Integer;
AReadyEvent: TNotifyEvent);
begin
TThread.CreateAnonymousThread(
procedure
var
i: Integer;
w : TSimpleEvent;
begin
w := TSimpleEvent.Create(Nil,False,False,'');
try
for i := FromValue to ToValue do begin
TThread.Synchronize(nil,
procedure
begin
aProc(i);
end
);
w.WaitFor(AnimationDelay);
end;
finally
w.Free;
end;
if Assigned(AReadyEvent) then
TThread.Synchronize(nil,
procedure
begin
AReadyEvent(Nil);
end
);
end
).Start;
end;
// Example call
AnimateThread(
procedure(aValue: Integer)
begin
ProgressBar1.Position := aValue;
ProgressBar1.Update;
end,
1,100,5,nil
);
You can do this easily with RTTI.
You cannot avoid writing a loop, but you can write it once and call your Animate method for any object/property you want to set. Of course, writing such a function is still tricky because you have to take into account flickering, time the UI is blocking, etc.
A very simple example would be something in the lines of:
implementation
uses RTTI;
procedure TForm1.Animate(AObj: TObject; APropertyName: string; AValue: Integer);
var
Context: TRTTIContext;
OType: TRTTIType;
Prop: TRTTIProperty;
StartValue: Integer;
begin
Context := TRTTIContext.Create;
OType := context.GetType(AObj.ClassType);
Prop := OType.GetProperty(APropertyName);
StartValue := Prop.GetValue(AObj).AsInteger;
for AValue := StartValue to AValue do
begin
Prop.SetValue(AObj, AValue);
if AObj is TWinControl then
begin
TWinControl(AObj).Update;
Sleep(3);
end;
end;
end;
//call it like this:
procedure TForm1.Button1Click(Sender: TObject);
begin
Animate(ProgressBar1, 'Position', 30);
Animate(Self, 'Height', 300);
end;
As David says, you will need to use Timers. Here's some code the demonstates the principle. I would advise that you take the idea and roll them into your own TProgressbar descendant.
Be aware that under Vista and Windows 7 TProgressBar has some built in animations when incrementing the position. This can produce odd effects when using your own animation.
You don't mention which version of Delphi you are using. This example was created using XE2. If you are using an earlier version you may need to fix the dotted unit names in the uses clause e.g. Winapi.Windows should be Windows.
Code:
unit Unit11;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.StdCtrls, Vcl.ExtCtrls,
Vcl.Samples.Spin;
type
TForm11 = class(TForm)
ProgressBar1: TProgressBar;
Timer1: TTimer;
Button1: TButton;
Button2: TButton;
spnIncrement: TSpinEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
FDestPos: Integer;
FProgInc: Integer;
procedure AnimateTo(const DestPos, Increment: Integer);
public
{ Public declarations }
end;
var
Form11: TForm11;
implementation
{$R *.dfm}
procedure TForm11.Button1Click(Sender: TObject);
begin
AnimateTo(10, spnIncrement.Value);
end;
procedure TForm11.Button2Click(Sender: TObject);
begin
AnimateTo(90, spnIncrement.Value);
end;
procedure TForm11.Timer1Timer(Sender: TObject);
begin
if ((FProgInc > 0) and (ProgressBar1.Position + FProgInc >= FDestPos)) or
((FProgInc < 0) and (ProgressBar1.Position + FProgInc <= FDestPos)) then
begin
ProgressBar1.Position := FDestPos;
Timer1.Enabled := FALSE;
end
else
begin
ProgressBar1.Position := ProgressBar1.Position + FProgInc;
end;
end;
procedure TForm11.AnimateTo(const DestPos, Increment: Integer);
begin
FDestPos := DestPos;
FProgInc := Increment;
if FDestPos < ProgressBar1.Position then
FProgInc := -FProgInc;
Timer1.Enabled := FProgInc <> 0;
end;
end.
DFM:
object Form11: TForm11
Left = 0
Top = 0
BorderStyle = bsDialog
Caption = 'Animated Progressbar'
ClientHeight = 77
ClientWidth = 466
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object Label1: TLabel
Left = 309
Top = 42
Width = 53
Height = 13
Caption = 'Increment:'
end
object ProgressBar1: TProgressBar
Left = 24
Top = 16
Width = 417
Height = 17
TabOrder = 0
end
object Button1: TButton
Left = 24
Top = 39
Width = 75
Height = 25
Caption = '10%'
TabOrder = 1
OnClick = Button1Click
end
object Button2: TButton
Left = 105
Top = 39
Width = 75
Height = 25
Caption = '90%'
TabOrder = 2
OnClick = Button2Click
end
object spnIncrement: TSpinEdit
Left = 368
Top = 39
Width = 73
Height = 22
MaxValue = 100
MinValue = 1
TabOrder = 3
Value = 0
end
object Timer1: TTimer
Enabled = False
Interval = 20
OnTimer = Timer1Timer
Left = 240
Top = 40
end
end
You can't assign anything other than an integer to a progress bar's position. So, if you want to make the position move smoothly from one value to another you need to set the position to each individual value.
There are no handy shortcuts. There's nothing available out of the box like jQuery's animate() method. You mention timers and loops. Those are the methods you need to use.

Resources