Related
I have a simple form that only contains a TTouchKeyboard. The forms BorderStyle is set to bsToolWindow. To avoid the form getting focus when clicking the touch keyboard I handle the WM_MOUSEACTIVATE message with this implementation:
procedure TKeyboardForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
The BorderStyle setting allows the form to be dragged with the title bar, but in that case the form still gets the focus. Is there a way to avoid this?
Update: I tried adding WS_EX_NOACTIVATE to ExStyle in CreateParams, but unfortunately that doesn't hinder the form to receive focus when dragged.
procedure TKeyboardForm.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.ExStyle := Params.ExStyle or WS_EX_NOACTIVATE;
end;
Because I was not very pleased with the approach that requires me to manually update the focused form variable in the keyboard form, I searched for a more transparent solution and came up with this approach.
Update: The previous approach had some issues with VCL styles. In addition not all of the message handlers were really necessary, though others turned out to be helpful, too. This version works well with VCL styles avoiding any flicker as far as possible:
type
TKeyboardForm = class(TForm)
TouchKeyboard1: TTouchKeyboard;
private
FLastFocusedForm: TCustomForm;
procedure SetLastFocusedForm(const Value: TCustomForm);
protected
procedure WMActivate(var Message: TWMActivate); message WM_ACTIVATE;
procedure WMMouseActivate(var Message: TWMMouseActivate); message WM_MOUSEACTIVATE;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
property LastFocusedForm: TCustomForm read FLastFocusedForm write SetLastFocusedForm;
public
class constructor Create;
destructor Destroy; override;
function SetFocusedControl(Control: TWinControl): Boolean; override;
end;
type
TKeyboardFormStyleHook = class(TFormStyleHook)
protected
procedure WMNCActivate(var Message: TWMNCActivate); message WM_NCACTIVATE;
end;
procedure TKeyboardFormStyleHook.WMNCActivate(var Message: TWMNCActivate);
begin
{ avoids the title bar being drawn active for blink }
Message.Active := False;
inherited;
end;
class constructor TKeyboardForm.Create;
begin
TCustomStyleEngine.RegisterStyleHook(TKeyboardForm, TKeyboardFormStyleHook);
end;
destructor TKeyboardForm.Destroy;
begin
LastFocusedForm := nil;
inherited;
end;
procedure TKeyboardForm.Notification(AComponent: TComponent; Operation: TOperation);
begin
if (Operation = opRemove) and (AComponent = FLastFocusedForm) then begin
FLastFocusedForm := nil;
end;
inherited;
end;
function TKeyboardForm.SetFocusedControl(Control: TWinControl): Boolean;
begin
LastFocusedForm := Screen.FocusedForm;
result := inherited;
end;
procedure TKeyboardForm.SetLastFocusedForm(const Value: TCustomForm);
begin
if FLastFocusedForm <> Value then
begin
if FLastFocusedForm <> nil then begin
FLastFocusedForm.RemoveFreeNotification(Self);
end;
FLastFocusedForm := Value;
if FLastFocusedForm <> nil then begin
FLastFocusedForm.FreeNotification(Self);
end;
end;
end;
procedure TKeyboardForm.WMActivate(var Message: TWMActivate);
begin
Message.Active := WA_INACTIVE;
inherited;
end;
procedure TKeyboardForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
inherited;
Message.Result := MA_NOACTIVATE;
end;
procedure TKeyboardForm.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
if (FLastFocusedForm <> nil) and (message.FocusedWnd <> FLastFocusedForm.Handle) then begin
SendMessage(FLastFocusedForm.Handle, WM_SETFOCUS, 0, 0);
Message.FocusedWnd := FLastFocusedForm.Handle;
end;
end;
The following combination of WMMouseActivate(), WMNCActivate() and reseting focus seems to fulfill your wishes:
The keyboard form (with BorderStyle = bsToolWindow) has message handlers for WM_MOUSEACTIVATE (as you already have) and WM_NCACTIVATE. The latter for having a point where to reset focus to the window with the edit control.
In addition the keyboardform will keep track of which form holds the edit (or other) control that has focus, and does that by introducing a new method for showing, which I called ShowUnfocused() and a field called FocusedForm: THandle.
procedure TKbdForm.ShowUnfocused(FocusedWindow: THandle);
begin
FocusedForm := FocusedWindow;
Show;
end;
procedure TKbdForm.FormShow(Sender: TObject);
begin
SetForegroundWindow(FocusedForm);
end;
procedure TKbdForm.WMMouseActivate(var Message: TWMMouseActivate);
begin
Message.Result := MA_NOACTIVATE;
end;
procedure TKbdForm.WMNCActivate(var Message: TWMNCActivate);
begin
Message.Result := 1; // important
SetForegroundWindow(FocusedForm);
end;
The keyboardform is invoked by the following common code of the edit controls:
procedure TForm17.EditClick(Sender: TObject);
begin
KbdForm.ShowUnfocused(self.Handle);
(Sender as TWinControl).SetFocus;
end;
An alternative to what is said above, could be to set the BorderStyle = bsNone and arrange the dragging of the form with the Mouse Down, Move, Up events directly from the forms surface (or maybe a panel to mimic a top frame), and adding a close button. The challenge would be to get it visually acceptable.
Overview
I am trying to write my own simple property inspector but I am facing a difficult and rather confusing problem. First though let me say that my component is not meant to work with or handle component properties, instead it will allow adding custom values to it. The full source code of my component is further down the question and it should look something like this once you have installed it in a package and run it from a new empty project:
Problem (brief)
The issue is regarding the use of inplace editors and validating the property values. The idea is, if a property value is not valid then show a message to the user notifying them that the value cannot be accepted, then focus back to the row and inplace editor that was originally focused on.
We can actually use Delphi's very own Object Inspector to illustrate the behavior I am looking for, for example try writing a string in the Name property that cannot be accepted then click away from the Object Inspector. A message is shown and upon closing it, it will focus back to the Name row.
Source Code
The question becomes too vague without any code but due to the nature of the component I am trying to write it's also quite large. I have stripped it down as much as possible for the purpose of the question and example. I am sure there will be some comments asking me why I didn't do this or do that instead but it's important to know that I am no Delphi expert and often I make wrong decisions and choices but I am always willing to learn so all comments are welcomed, especially if it aids in finding my solution.
unit MyInspector;
interface
uses
Winapi.Windows,
Winapi.Messages,
System.Classes,
System.SysUtils,
Vcl.Controls,
Vcl.Dialogs,
Vcl.StdCtrls,
Vcl.Graphics,
Vcl.Forms;
type
TMyInspectorItems = class(TObject)
private
FPropertyNames: TStringList;
FPropertyValues: TStringList;
procedure AddItem(APropName, APropValue: string);
procedure Clear;
public
constructor Create;
destructor Destroy; override;
end;
TOnMouseMoveEvent = procedure(Sender: TObject; X, Y: Integer) of object;
TOnSelectRowEvent = procedure(Sender: TObject; PropName, PropValue: string; RowIndex: Integer) of object;
TMyCustomInspector = class(TGraphicControl)
private
FInspectorItems: TMyInspectorItems;
FOnMouseMove: TOnMouseMoveEvent;
FOnSelectRow: TOnSelectRowEvent;
FRowCount: Integer;
FNamesFont: TFont;
FValuesFont: TFont;
FSelectedRow: Integer;
procedure SetNamesFont(const AValue: TFont);
procedure SetValuesFont(const AValue: TFont);
procedure CalculateInspectorHeight;
function GetMousePosition: TPoint;
function MousePositionToRowIndex: Integer;
function RowIndexToMousePosition(ARowIndex: Integer): Integer;
function GetRowHeight: Integer;
function GetValueRowWidth: Integer;
function RowExists(ARowIndex: Integer): Boolean;
function IsRowSelected: Boolean;
protected
procedure Loaded; override;
procedure Paint; override;
procedure WMKeyDown(var Message: TMessage); message WM_KEYDOWN;
procedure WMMouseDown(var Message: TMessage); message WM_LBUTTONDOWN;
procedure WMMouseMove(var Message: TMessage); message WM_MOUSEMOVE;
procedure WMMouseUp(var Message: TMessage); message WM_LBUTTONUP;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function RowCount: Integer;
property Items: TMyInspectorItems read FInspectorItems write FInspectorItems;
property OnMouseMove: TOnMouseMoveEvent read FOnMouseMove write FOnMouseMove;
property OnSelectRow: TOnSelectRowEvent read FOnSelectRow write FOnSelectRow;
published
property Align;
end;
TMyPropertyInspector = class(TScrollBox)
private
FInspector: TMyCustomInspector;
FInplaceStringEditor: TEdit;
FSelectedRowName: string;
FLastSelectedRowName: string;
FLastSelectedRow: Integer;
function SetPropertyValue(RevertToPreviousValueOnFail: Boolean): Boolean;
procedure InplaceStringEditorEnter(Sender: TObject);
procedure InplaceStringEditorExit(Sender: TObject);
procedure InplaceStringEditorKeyPress(Sender: TObject; var Key: Char);
procedure SelectRow(Sender: TObject; PropName, PropValue: string; RowIndex: Integer);
function ValidateStringValue(Value: string): Boolean;
protected
procedure Loaded; override;
procedure WMSize(var Message: TMessage); message WM_SIZE;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure AddItem(APropName, APropValue: string);
function GetSelectedPropertyName: string;
function GetSelectedPropertyValue: string;
function RowCount: Integer;
end;
var
FCanSelect: Boolean;
implementation
{ TMyInspectorItems }
constructor TMyInspectorItems.Create;
begin
inherited Create;
FPropertyNames := TStringList.Create;
FPropertyValues := TStringList.Create;
end;
destructor TMyInspectorItems.Destroy;
begin
FPropertyNames.Free;
FPropertyValues.Free;
inherited Destroy;
end;
procedure TMyInspectorItems.AddItem(APropName, APropValue: string);
begin
FPropertyNames.Add(APropName);
FPropertyValues.Add(APropValue);
end;
procedure TMyInspectorItems.Clear;
begin
FPropertyNames.Clear;
FPropertyValues.Clear;
end;
{ TMyCustomInspector }
constructor TMyCustomInspector.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FInspectorItems := TMyInspectorItems.Create;
FNamesFont := TFont.Create;
FNamesFont.Color := clWindowText;
FNamesFont.Name := 'Segoe UI';
FNamesFont.Size := 9;
FNamesFont.Style := [];
FValuesFont := TFont.Create;
FValuesFont.Color := clNavy;
FValuesFont.Name := 'Segoe UI';
FValuesFont.Size := 9;
FValuesFont.Style := [];
end;
destructor TMyCustomInspector.Destroy;
begin
FInspectorItems.Free;
FNamesFont.Free;
FValuesFont.Free;
inherited Destroy;
end;
procedure TMyCustomInspector.Loaded;
begin
inherited Loaded;
end;
procedure TMyCustomInspector.Paint;
procedure DrawBackground;
begin
Canvas.Brush.Color := clWindow;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(0, 0, Self.Width, Self.Height));
end;
procedure DrawNamesBackground;
begin
Canvas.Brush.Color := clWindow;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(0, 0, Self.Width div 2, Self.Height));
end;
procedure DrawNamesSelection;
begin
if (FRowCount > -1) and (RowExists(MousePositionToRowIndex)) then
begin
Canvas.Brush.Color := $00E0E0E0;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(0, RowIndexToMousePosition(FSelectedRow),
Self.Width div 2, RowIndexToMousePosition(FSelectedRow) + GetRowHeight));
end;
end;
procedure DrawNamesText;
var
I: Integer;
Y: Integer;
begin
FRowCount := FInspectorItems.FPropertyNames.Count;
Canvas.Brush.Style := bsClear;
Canvas.Font.Color := FNamesFont.Color;
Canvas.Font.Name := FNamesFont.Name;
Canvas.Font.Size := FNamesFont.Size;
Y := 0;
for I := 0 to FInspectorItems.FPropertyNames.Count -1 do
begin
Canvas.TextOut(2, Y, FInspectorItems.FPropertyNames.Strings[I]);
Inc(Y, GetRowHeight);
end;
end;
procedure DrawValuesBackground;
begin
Canvas.Brush.Color := clWindow;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(Rect(Self.Width div 2, 0, Self.Width, Self.Height));
end;
procedure DrawValuesSelection;
begin
if (FRowCount > -1) and (RowExists(MousePositionToRowIndex)) then
begin
Canvas.DrawFocusRect(Rect(Self.Width div 2, RowIndexToMousePosition(FSelectedRow),
Self.Width, RowIndexToMousePosition(FSelectedRow) + GetRowHeight));
end;
end;
procedure DrawValues;
var
I, Y: Integer;
begin
FRowCount := FInspectorItems.FPropertyValues.Count;
Y := 0;
for I := 0 to FInspectorItems.FPropertyValues.Count -1 do
begin
Canvas.Brush.Style := bsClear;
Canvas.Font.Color := FValuesFont.Color;
Canvas.Font.Name := FValuesFont.Name;
Canvas.Font.Size := FValuesFont.Size;
Canvas.TextOut(Self.Width div 2 + 2, Y + 1, FInspectorItems.FPropertyValues.Strings[I]);
Inc(Y, GetRowHeight);
end;
end;
begin
DrawNamesBackground;
DrawNamesSelection;
DrawNamesText;
DrawValuesBackground;
DrawValuesSelection;
DrawValues;
end;
procedure TMyCustomInspector.WMKeyDown(var Message: TMessage);
begin
inherited;
case Message.WParam of
VK_DOWN:
begin
end;
end;
end;
procedure TMyCustomInspector.WMMouseDown(var Message: TMessage);
begin
inherited;
Parent.SetFocus;
FSelectedRow := MousePositionToRowIndex;
if FSelectedRow <> -1 then
begin
if Assigned(FOnSelectRow) then
begin
FOnSelectRow(Self, FInspectorItems.FPropertyNames.Strings[FSelectedRow],
FInspectorItems.FPropertyValues.Strings[FSelectedRow], FSelectedRow);
end;
end;
Invalidate;
end;
procedure TMyCustomInspector.WMMouseMove(var Message: TMessage);
begin
inherited;
if Assigned(FOnMouseMove) then
begin
FOnMouseMove(Self, GetMousePosition.X, GetMousePosition.Y);
end;
end;
procedure TMyCustomInspector.WMMouseUp(var Message: TMessage);
begin
inherited;
end;
procedure TMyCustomInspector.SetNamesFont(const AValue: TFont);
begin
FNamesFont.Assign(AValue);
Invalidate;
end;
procedure TMyCustomInspector.SetValuesFont(const AValue: TFont);
begin
FValuesFont.Assign(AValue);
Invalidate;
end;
procedure TMyCustomInspector.CalculateInspectorHeight;
var
I, Y: Integer;
begin
FRowCount := FInspectorItems.FPropertyNames.Count;
Y := GetRowHeight;
for I := 0 to FRowCount -1 do
begin
Inc(Y, GetRowHeight);
end;
if Self.Height <> Y then
Self.Height := Y;
end;
function TMyCustomInspector.GetMousePosition: TPoint;
var
Pt: TPoint;
begin
Pt := Mouse.CursorPos;
Pt := ScreenToClient(Pt);
Result := Pt;
end;
function TMyCustomInspector.MousePositionToRowIndex: Integer;
begin
Result := GetMousePosition.Y div GetRowHeight;
end;
function TMyCustomInspector.RowIndexToMousePosition(
ARowIndex: Integer): Integer;
begin
Result := ARowIndex * GetRowHeight;
end;
function TMyCustomInspector.GetRowHeight: Integer;
begin
Result := FNamesFont.Size * 2 + 1;
end;
function TMyCustomInspector.GetValueRowWidth: Integer;
begin
Result := Self.Width div 2;
end;
function TMyCustomInspector.RowCount: Integer;
begin
Result := FRowCount;
end;
function TMyCustomInspector.RowExists(ARowIndex: Integer): Boolean;
begin
Result := MousePositionToRowIndex < RowCount;
end;
function TMyCustomInspector.IsRowSelected: Boolean;
begin
Result := FSelectedRow <> -1;
end;
{ TMyPropertyInspector }
constructor TMyPropertyInspector.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Self.DoubleBuffered := True;
Self.Height := 150;
Self.HorzScrollBar.Visible := False;
Self.TabStop := True; // needed to receive focus
Self.Width := 250;
FInspector := TMyCustomInspector.Create(Self);
FInspector.Parent := Self;
FInspector.Align := alTop;
FInspector.Height := 0;
FInspector.OnSelectRow := SelectRow;
FInplaceStringEditor := TEdit.Create(Self);
FInplaceStringEditor.Parent := Self;
FInplaceStringEditor.BorderStyle := bsNone;
FInplaceStringEditor.Color := clWindow;
FInplaceStringEditor.Height := 0;
FInplaceStringEditor.Left := 0;
FInplaceStringEditor.Name := 'MyPropInspectorInplaceStringEditor';
FInplaceStringEditor.Top := 0;
FInplaceStringEditor.Visible := False;
FInplaceStringEditor.Width := 0;
FInplaceStringEditor.Font.Assign(FInspector.FValuesFont);
FInplaceStringEditor.OnEnter := InplaceStringEditorEnter;
FInplaceStringEditor.OnExit := InplaceStringEditorExit;
FInplaceStringEditor.OnKeyPress := InplaceStringEditorKeyPress;
FCanSelect := True;
end;
destructor TMyPropertyInspector.Destroy;
begin
FInspector.Free;
FInplaceStringEditor.Free;
inherited Destroy;
end;
procedure TMyPropertyInspector.Loaded;
begin
inherited Loaded;
end;
procedure TMyPropertyInspector.WMSize(var Message: TMessage);
begin
FInspector.Width := Self.Width;
Invalidate;
end;
procedure TMyPropertyInspector.AddItem(APropName, APropValue: string);
begin
FInspector.CalculateInspectorHeight;
FInspector.Items.AddItem(APropName, APropValue);
FInspector.Invalidate;
Self.Invalidate;
end;
function TMyPropertyInspector.GetSelectedPropertyName: string;
begin
Result := '';
if FInspector.FSelectedRow <> -1 then
begin
Result := FInspector.FInspectorItems.FPropertyNames.Strings[FInspector.FSelectedRow];
end;
end;
function TMyPropertyInspector.GetSelectedPropertyValue: string;
begin
Result := '';
if FInspector.FSelectedRow <> -1 then
begin
Result := FInspector.FInspectorItems.FPropertyValues.Strings[FInspector.FSelectedRow];
end;
end;
function TMyPropertyInspector.RowCount: Integer;
begin
Result := FInspector.RowCount;
end;
procedure TMyPropertyInspector.InplaceStringEditorEnter(Sender: TObject);
begin
FCanSelect := False;
FLastSelectedRow := FInplaceStringEditor.Tag;
end;
procedure TMyPropertyInspector.InplaceStringEditorExit(Sender: TObject);
begin
if SetPropertyValue(True) then
begin
FCanSelect := True;
end;
end;
procedure TMyPropertyInspector.InplaceStringEditorKeyPress(Sender: TObject;
var Key: Char);
begin
if Key = Chr(VK_RETURN) then
begin
Key := #0;
FInplaceStringEditor.SelectAll;
end;
end;
procedure TMyPropertyInspector.SelectRow(Sender: TObject; PropName, PropValue: string; RowIndex: Integer);
begin
FSelectedRowName := PropName;
FLastSelectedRowName := PropName;
FInplaceStringEditor.Height := FInspector.GetRowHeight - 2;
FInplaceStringEditor.Left := Self.Width div 2;
FInplaceStringEditor.Tag := RowIndex;
FInplaceStringEditor.Text := GetSelectedPropertyValue;
FInplaceStringEditor.Top := FInspector.RowIndexToMousePosition(FInspector.FSelectedRow) + 1 - Self.VertScrollBar.Position;
FInplaceStringEditor.Visible := True;
FInplaceStringEditor.Width := FInspector.GetValueRowWidth - 3;
FInplaceStringEditor.SetFocus;
FInplaceStringEditor.SelectAll;
end;
function TMyPropertyInspector.SetPropertyValue(
RevertToPreviousValueOnFail: Boolean): Boolean;
var
S: string;
begin
Result := False;
S := FInplaceStringEditor.Text;
if ValidateStringValue(S) then
begin
Result := True;
end
else
begin
ShowMessage('"' + S + '"' + 'is not a valid value.');
Result := False;
end;
end;
function TMyPropertyInspector.ValidateStringValue(Value: string): Boolean;
begin
// a quick and dirty way of testing for a valid string value, here we just
// look for strings that are not zero length.
Result := Length(Value) > 0;
end;
end.
Problem (detailed)
The confusion I have all comes down to who receives focus first and how to handle and respond to it correctly. Because I am custom drawing my rows I determine where the mouse is when clicking on the inspector control and then I draw the selected row to show this. When handling the inplace editors however, especially the OnEnter and OnExit event I have been facing all kinds of funky problems where in some cases I have been stuck in a cycle of the validate error message repeatedly showing for example (because focus is switching from my inspector to the inplace editor and back and forth).
To populate my inspector at runtime you can do the following:
procedure TForm1.Button1Click(Sender: TObject);
begin
MyPropertyInspector1.AddItem('A', 'Some Text');
MyPropertyInspector1.AddItem('B', 'Hello World');
MyPropertyInspector1.AddItem('C', 'Blah Blah');
MyPropertyInspector1.AddItem('D', 'The Sky is Blue');
MyPropertyInspector1.AddItem('E', 'Another String');
end;
A little something you may try:
Click on a row
Delete the contents from the inplace editor
Select another row
The validate error message box appears (don't close it yet)
With the message box still visible, move your mouse over another row
Now press Enter to close the message box
You will notice the selected row has now moved to where the mouse was
What I need is after the validate message box has shown and closed, I need to set the focus back to the row that was been validated in the first place. It gets confusing because it seems (or so I think) that the inplace editors OnExit is been called after the WMMouseDown(var Message: TMessage); code of my inspector.
To put it as simple as I can if the question remains unclear, the behavior of the Delphi Object Inspector is what I am trying to implement into my component. You enter a value into the inplace editors, if it fails the validation then display a messagebox and then focus back to the row that was last selected. The inplace editor validation should occur as soon as focus is switched away from the inplace editor.
I just can't seem to figure out what is been called first and what is blocking events been fired, it becomes confusing because the way I draw my selected row is determined by where the mouse was when clicking on the inspector control.
This is your flow of events:
TMyCustomInspector.WMMouseDown is called
Therein, Parent.SetFocus is called
The focus is removed from the Edit control and TMyPropertyInspector.InplaceStringEditorExit is called
The message dialog is shown by SetPropertyValue
FSelectedRow is being reset
TMyPropertyInspector.SelectRow is called (via TMyCustomInspector.FOnSelectRow) which resets the focus to the replaced Edit control.
What you need to is to prevent FSelectedRow being reset in case of validation did not succeed. All needed ingredients are already there, just add this one condition:
if FCanSelect then
FSelectedRow := MousePositionToRowIndex;
A few remarks:
Make FCanSelect a protected or private field of TMyCustomInspector,
You need to check for limits in TMyCustomInspector.MousePositionToRowIndex in order to return -1.
Your problem is very interesting. From what I gather, you want a way to reset the focus to the invalid row, when the evaluation is false. Where I see you do this is in your SetPropertyValue function. I believe if you do the following, you will be able to reset the focus after the user clicks "OK" in the message:
function TMyPropertyInspector.SetPropertyValue(
RevertToPreviousValueOnFail: Boolean): Boolean;
var
S: string;
begin
Result := False;
S := FInplaceStringEditor.Text;
if ValidateStringValue(S) then
begin
Result := True;
end
else
begin
if (MessageDlg('"' + S + '"' + 'is not a valid value.', mtError, [mbOK], 0)) = mrOK then
begin
SelectRow(nil, FSelectedRowName, FInplaceStringEditor.Text, FInplaceStringEditor.Tag);
end;
Result := False;
end;
end;
Changing the ShowMessage to MessageDlg will allow for an action to occur when the button is pressed. Then calling your SelectRow function with (what I believe are) global variables representing the information about the last row will set that focus to the bad cell.
I am writing a class which will map a large legacy application's TMainMenu hierarchy to TActionMainMenuBar items.
The most important method, which borrows heavily from a EDN CodeCentralC article by Steve Trevethen, looks like this. I apologize for the length, but this really is probably the shortest length of code I could meaningfully show in this case:
procedure TMainMenuSkin.DoLoadMenu(
ActionList: TCustomActionList;
Clients: TActionClients;
AMenu: TMenuItem;
SetActionList: Boolean = True;
bRecurseFlag:Boolean = False);
var
I: Integer;
J: Integer;
AC: TActionClientItem;
ca : TCustomAction;
newAction : TSkinnedMenuAction;
aci:TActionClientItem;
submenuitem : TMEnuItem;
procedure PopulateNodeFromMenuItem(menuitem:TMenuItem);
begin
newAction := TSkinnedMenuAction.Create(Application.MainForm);
menuitem.FreeNotification(newAction);
newAction.FMenuItem := menuitem;
newAction.Name := 'action_'+newAction.FMenuItem.Name;
FNewMenuActions.Add(newAction);
newAction.ActionList := ActionManager;
newAction.Tag := menuitem.Tag;
ca := newAction;
ca.ImageIndex := menuitem.ImageIndex;
ca.HelpContext := menuitem.HelpContext;
ca.Visible := menuitem.Visible;
ca.Checked := menuitem.Checked;
ca.Caption := menuitem.Caption;
ca.ShortCut := menuitem.ShortCut;
ca.Enabled := menuitem.Enabled;
ca.AutoCheck := menuitem.AutoCheck;
ca.Checked := menuitem.Checked;
ca.GroupIndex := menuitem.GroupIndex;
AC.ImageIndex := menuitem.ImageIndex;
AC.ShortCut := menuitem.ShortCut;
AC.Action := newAction;
end;
begin
if not Assigned(AMenu) then
exit;
AMenu.RethinkHotkeys;
AMenu.RethinkLines;
Clients.AutoHotKeys := False;
for I := 0 to AMenu.Count - 1 do
begin
AC := Clients.Add;
AC.Caption := AMenu.Items[I].Caption;
// Assign the Tag property to the TMenuItem for reference
AC.Tag := Integer(AMenu.Items[I]);
AC.Action := TContainedAction(AMenu.Items[I].Action);
AC.Visible := AMenu.Items[I].Visible;
// original sample code only created placeholders for submenus. I want to populate
// fully because I need the actions and their keyboard shortcuts to exist.
submenuitem := AMenu.Items[I];
if submenuitem.Count > 0 then
begin
if not bRecurseFlag then
AC.Items.Add // old busted way to work
else
begin
// How do I recursively populate the Action Clients menu?
DoLoadMenu(ActionList, AC.ActionClients, submenuitem, true);
end;
end
else
if ((AMenu.Items[I].Caption <> '') and (AMenu.Items[I].Action = nil) and
(AMenu.Items[I].Caption <> '-')) then
begin
PopulateNodeFromMenuItem( AMenu.Items[I] );
end;
AC.Caption := AMenu.Items[I].Caption;
AC.ImageIndex := AMenu.Items[I].ImageIndex;
AC.HelpContext := AMenu.Items[I].HelpContext;
AC.ShortCut := AMenu.Items[I].ShortCut;
AC.Visible := AMenu.Items[I].Visible;
end;
end;
The most important line above is this one, and it's also the one
that is wrong:
DoLoadMenu(ActionList, AC.ActionClients, submenuitem, true);
If the code is written like that, then I get all the menu items displayed in a flattened form. So I need something like AC.GetMeSubItems.ActionClients in the line above,
but I can't figure out what it is. AC is of type TActionClientItem and is a toolbar button itself also created at runtime.
What I can't figure out for the life of me is, if I need to populate the Actions list and the menu items all at once, recursively, how do I do it? Perhaps my thinking is constrained by the sample code I started out with here. It seems like I'm one line of code away from knowing how to do this.
I have a feeling that I'm just not understanding very well the complex hiearchical relationships of the various classes I'm messing with here.
Update: The following SEEMS to work, but I don't trust myself.
aci := AC.Items.Add;
DoLoadMenu(ActionList, aci.Items, submenuitem, true);
Here's some code that I once wrote or found somewhere and which seems to do what you want to achieve: it is a converter class which copies the items of a Mainmenu to an ActionMainMenubar. It has some issues, but hopefully you can catch the point how it works.
The component assumes that you have a completed MainMenu on a form. You also need a TActionManager and an empty TActionMainMenubar. You create an instance of the TActionbarConverter in the OnCreate event of the MainForm, and assign its properties correspondingly, something like this:
procedure TForm1.FormCreate(Sender: TObject);
begin
with TActionbarConverter.Create(self) do begin
Form := self;
ActionManager := Actionmanager1;
ActionMainMenubar := ActionMainmenubar1;
end;
end;
You can change properties of the ActionManager, or use your own ColorMap to modify the appearance.
I hope that I don't get banned here by posting almost 400 lines of code here (don't know how to upload files...).
unit ActnbarCnv;
interface
uses
Classes, Menus, Forms, ComCtrls, ActnList, ActnMan, ActnMenus,
StdStyleActnCtrls, XPStyleActnCtrls;
type
TActionbarConverter = class(TComponent)
private
FForm : TCustomForm;
FMainMenu : TMainMenu;
FMainMenuToolbar : TToolbar;
FActionManager : TActionManager;
FActionMainMenubar : TActionMainMenubar;
FNewMenuActions : TList;
procedure ActionMainMenuBar_ExitMenuLoop(Sender:TCustomActionMenuBar;
Cancelled: Boolean);
procedure ActionMainMenubar_Popup(Sender:TObject; Item:TCustomActionControl);
procedure SetActionMainMenubar(Value:TActionMainMenubar);
procedure SetActionManager(Value:TActionManager);
procedure SetForm(Value:TCustomForm);
protected
procedure AnalyzeForm;
procedure Loaded; override;
procedure LoadMenu(ActionList: TCustomActionList; Clients: TActionClients;
AMenu: TMenuItem; SetActionList: Boolean = True);
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure ProcessMenu;
procedure UpdateActionMainMenuBar(Menu: TMenu);
public
constructor Create(AOwner:TComponent); override;
destructor Destroy; override;
procedure Update;
published
property Form : TCustomForm read FForm write SetForm;
property ActionManager : TActionManager read FActionManager write SetActionManager;
property ActionMainMenubar : TActionMainMenubar read FActionMainMenubar write SetActionMainMenubar;
end;
//==============================================================================
implementation
//==============================================================================
uses
SysUtils;
//==============================================================================
{ TABMenuAction -
This class is a special ActionBand menu action that stores the TMenuItem
that it is associated with so that if it is executed it can actually call the
TMenuItem.Click method simulating an actual click on the TMenuItem itself. }
type
TABMenuAction = class(TCustomAction)
private
FMenuItem: TMenuItem;
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
destructor Destroy; override;
procedure ExecuteTarget(Target: TObject); override;
function HandlesTarget(Target: TObject): Boolean; override;
end;
//------------------------------------------------------------------------------
destructor TABMenuAction.Destroy;
begin
if Assigned(FMenuItem) then FMenuItem.RemoveFreeNotification(Self);
inherited;
end;
//------------------------------------------------------------------------------
procedure TABMenuAction.ExecuteTarget(Target: TObject);
begin
if Assigned(FMenuItem) then FMenuItem.Click;
end;
//------------------------------------------------------------------------------
function TABMenuAction.HandlesTarget(Target: TObject): Boolean;
begin
Result := True;
end;
//------------------------------------------------------------------------------
procedure TABMenuAction.Notification(AComponent: TComponent; Operation: TOperation);
begin
if (Operation = opRemove) and (AComponent = FMenuItem)
then FMenuItem := nil;
end;
//------------------------------------------------------------------------------
// TActionbarConverter
//------------------------------------------------------------------------------
constructor TActionbarConverter.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
FNewMenuActions := TList.Create;
if (AOwner is TCustomForm) then SetForm(TCustomForm(AOwner));
end;
//------------------------------------------------------------------------------
destructor TActionbarConverter.Destroy;
begin
FNewMenuActions.Free;
inherited Destroy;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.ActionMainMenuBar_ExitMenuLoop(Sender:TCustomActionMenuBar;
Cancelled: Boolean);
var
I: Integer;
AnAction: TObject;
begin
// Clear the top level menu sub item and add a single dummy item which
// will cause them to be regenerated on the next menu loop. This is done
// because the IDE's menus can be very dynamic and this ensures that the
// menus will always be up-to-date.
for I := 0 to FActionManager.ActionBars[0].Items.Count - 1 do begin
FActionManager.ActionBars[0].Items[I].Items.Clear;
FActionManager.ActionBars[0].Items[I].Items.Add;
end;
// Any menuitems not linked to an action had one dynamically created for them
// during the menu loop so now we need to destroy them
while FNewMenuActions.Count > 0 do begin
AnAction := TObject(FNewMenuActions.Items[0]);
AnAction.Free;
FNewMenuActions.Delete(0);
end;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.ActionMainMenubar_Popup(Sender:TObject;
Item: TCustomActionControl);
begin
// If the tag is not zero then we've already populated this submenu...
if Item.ActionClient.Items[0].Tag <> 0 then exit;
// ...otherwise this is the first visit to this submenu and we need to
// populate the actual ActionClients collection.
if Assigned(TMenuItem(Item.ActionClient.Tag).OnClick) then
TMenuItem(Item.ActionClient.Tag).OnClick(TMenuItem(Item.ActionClient.Tag));
Item.ActionClient.Items.Clear;
TMenuItem(Item.ActionClient.Tag).RethinkHotkeys;
LoadMenu(FActionManager, Item.ActionClient.Items, TMenuItem(Item.ActionClient.Tag), False);
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.AnalyzeForm;
var
i : integer;
begin
FMainMenu := nil;
FMainMenuToolbar := nil;
if Assigned(FForm) then begin
for i:=0 to FForm.ComponentCount-1 do
if (FForm.Components[i] is TMainMenu) then begin
FMainMenu := FForm.Components[i] as TMainMenu;
break;
end;
for i:=0 to FForm.ComponentCount-1 do
if (FForm.Components[i] is TToolbar) then begin
FMainMenuToolbar := FForm.Components[i] as TToolbar;
if FMainMenuToolbar.Menu = FMainMenu
then break
else FMainMenuToolbar := nil;
end;
end;
ProcessMenu;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.Loaded;
begin
AnalyzeForm;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.LoadMenu(ActionList: TCustomActionList;
Clients: TActionClients; AMenu: TMenuItem; SetActionList: Boolean = True);
{ This method dynamically builds the ActionBand menu from an existing
TMenuItem. }
var
I: Integer;
AC: TActionClientItem;
begin
AMenu.RethinkHotkeys;
AMenu.RethinkLines;
// Use the existing hotkeys from the TMenuItem
Clients.AutoHotKeys := False;
for I := 0 to AMenu.Count - 1 do begin
AC := Clients.Add;
AC.Caption := AMenu.Items[I].Caption;
// Assign the Tag property to the TMenuItem for reference
AC.Tag := Integer(AMenu.Items[I]);
AC.Action := TContainedAction(AMenu.Items[I].Action);
AC.Visible := AMenu.Items[I].Visible;
// If the TMenuItem has subitems add an ActionClient placeholder.
// Submenus are only populated when the user selects the parent item of the
// submenu.
if AMenu.Items[I].Count > 0 then
AC.Items.Add // Add a dummy indicating this item can/should be dynamically built
else
if (AMenu.Items[I].Caption <> '')
and (AMenu.Items[I].Action = nil)
and (AMenu.Items[I].Caption <> '-')
then begin
// The TMenuItem is not connected to an action so dynamically create
// an action.
AC.Action := TABMenuAction.Create(self); //Application.MainForm);
AMenu.Items[I].FreeNotification(AC.Action);
TABMenuAction(AC.Action).FMenuItem := AMenu.Items[I];
FNewMenuActions.Add(AC.Action);
AC.Action.ActionList := FActionManager;
AC.Action.Tag := AMenu.Items[I].Tag;
TCustomAction(AC.Action).ImageIndex := AMenu.Items[I].ImageIndex;
TCustomAction(AC.Action).HelpContext := AMenu.Items[I].HelpContext;
TCustomAction(AC.Action).Visible := AMenu.Items[I].Visible;
TCustomAction(AC.Action).Checked := AMenu.Items[I].Checked;
TCustomAction(AC.Action).Caption := AMenu.Items[I].Caption;
TCustomAction(AC.Action).ShortCut := AMenu.Items[I].ShortCut;
TCustomAction(AC.Action).Enabled := AMenu.Items[I].Enabled;
TCustomAction(AC.Action).AutoCheck := AMenu.Items[I].AutoCheck;
TCustomAction(AC.Action).Checked := AMenu.Items[I].Checked;
TCustomAction(AC.Action).GroupIndex := AMenu.Items[I].GroupIndex;
AC.ImageIndex := AMenu.Items[I].ImageIndex;
AC.ShortCut := AMenu.Items[I].ShortCut;
end;
AC.Caption := AMenu.Items[I].Caption;
AC.ImageIndex := AMenu.Items[I].ImageIndex;
AC.HelpContext := AMenu.Items[I].HelpContext;
AC.ShortCut := AMenu.Items[I].ShortCut;
AC.Visible := AMenu.Items[I].Visible;
end;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited;
if (Operation = opRemove) then
if (AComponent=FForm) then SetForm(nil);
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.ProcessMenu;
begin
if FMainMenu <> nil then begin
if FMainMenutoolbar <> nil then begin
FMainMenutoolbar.Menu := nil;
FMainMenutoolbar.Visible := false;
end;
FForm.Menu := nil;
if FActionManager=nil then begin
FActionManager := TActionManager.Create(self);
// FActionManager.Style := XPStyle;
end else
FActionManager.Actionbars.Clear;
FActionManager.Images := FMainMenu.Images;
FActionManager.Actionbars.Add;
if FActionMainMenubar=nil then begin
FActionMainMenubar := TActionMainMenubar.Create(self);
if (FMainMenuToolbar <> nil)
then FActionMainMenubar.Parent := FMainMenuToolbar.Parent
else FActionMainMenubar.Parent := FForm;
end;
FActionMainMenubar.ActionManager := FActionManager;
FActionMainMenubar.OnPopup := ActionMainMenubar_Popup;
FActionMainMenubar.OnExitMenuLoop := ActionMainMenubar_ExitMenuLoop;
UpdateActionMainMenubar(FMainMenu);
end;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.SetActionMainmenubar(Value:TActionMainMenubar);
begin
if Value=nil then begin
FActionMainMenubar := TActionMainMenubar.Create(self);
if FMainmenuToolbar <> nil
then FActionMainMenubar.Parent := FMainMenuToolbar.Parent
else FActionMainMenubar.Parent := FForm;
end else begin
FActionMainMenubar.Free;
FActionMainMenubar := value;
end;
Update;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.SetActionManager(value:TActionManager);
begin
if Value = nil then begin
FActionManager := TActionManager.Create(self);
FActionManager.Style := XPStyle;
end else begin
FActionManager := value;
// if FMainMenu <> nil then FActionManager.Images := FMainMenu.Images;
end;
Update;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.SetForm(value:TCustomForm);
begin
if FForm <> Value then begin
FForm := Value;
AnalyzeForm;
end;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.Update;
begin
AnalyzeForm;
end;
//------------------------------------------------------------------------------
procedure TActionbarConverter.UpdateActionMainMenuBar(Menu: TMenu);
{ This routine should probably also check for Enabled state although it would
be very wierd to have a top level menu disabled. }
function RefreshItems: Boolean;
var
I: Integer;
begin
Result := FMainMenu.Items.Count <> FActionManager.ActionBars[0].Items.Count;
if not Result then
for I := 0 to FMainMenu.Items.Count - 1 do
if AnsiCompareText(
FMainMenu.Items[I].Caption,
FActionManager.ActionBars[0].Items[I].Caption ) <> 0
then begin
Result := True;
break;
end;
end;
begin
if not (csLoading in FActionManager.ComponentState) and RefreshItems
then begin
// Clear any existing items and repopulate the TActionMainMenuBar
FActionManager.ActionBars[0].Items.Clear;
FActionManager.ActionBars[0].ActionBar := nil;
LoadMenu(FActionManager, FActionManager.ActionBars[0].Items, FMainMenu.Items);
FActionManager.ActionBars[0].ActionBar := FActionMainMenuBar;
// Update the size of the main menu
with FActionMainMenuBar do
SetBounds(
0,
0,
Controls[ControlCount-1].BoundsRect.Right + 2 + FActionMainMenuBar.HorzMargin,
Height
);
end;
end;
end.
I'm trying to display a truly alpha blended TPanel in Delphi XE2. I've found quite a few attempts online, but none of them work correctly.
What I'm trying to achieve is a 'semi modal' form. A form that is displayed over the top of other controls with a faded background in a similar manner to that seen in web browsers.
I've got it working in a basic form, but it suffers from the following problems:
A large amount of flicker when resizing the panel.
If a control is moved over the top of the panel it leaves a trail.
Here's my efforts thus far (based on some code I found here).
unit SemiModalFormU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;
type
ISemiModalResultHandler = interface
['{0CC5A5D0-1545-4257-A936-AD777E0DAFCF}']
procedure SemiModalFormClosed(Form: TForm);
end;
TTransparentPanel = class(TCustomPanel)
private
FBackground: TBitmap;
FBlendColor: TColor;
FBlendAlpha: Byte;
procedure ColorBlend(const ACanvas: TCanvas; const ARect: TRect; const ABlendColor: TColor; const ABlendValue: Byte);
procedure SetBlendAlpha(const Value: Byte);
procedure SetBlendColor(const Value: TColor);
protected
procedure CaptureBackground;
procedure Paint; override;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure WMMove(var Message: TMessage); message WM_MOVE;
procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
procedure ClearBackground;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
property BlendColor: TColor read FBlendColor write SetBlendColor;
property BlendAlpha: Byte read FBlendAlpha write SetBlendAlpha;
property Align;
property Alignment;
property Anchors;
end;
TSemiModalForm = class(TComponent)
strict private
FFormParent: TWinControl;
FBlendColor: TColor;
FBlendAlpha: Byte;
FSemiModalResultHandler: ISemiModalResultHandler;
FForm: TForm;
FTransparentPanel: TTransparentPanel;
FOldFormOnClose: TCloseEvent;
private
procedure OnTransparentPanelResize(Sender: TObject);
procedure RepositionForm;
procedure SetFormParent(const Value: TWinControl);
procedure OnFormClose(Sender: TObject; var Action: TCloseAction);
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
procedure ShowSemiModalForm(AForm: TForm; SemiModalResultHandler: ISemiModalResultHandler); virtual;
property ModalPanel: TTransparentPanel read FTransparentPanel;
published
constructor Create(AOwner: TComponent); override;
property BlendColor: TColor read FBlendColor write FBlendColor;
property BlendAlpha: Byte read FBlendAlpha write FBlendAlpha;
property FormParent: TWinControl read FFormParent write SetFormParent;
end;
implementation
procedure TTransparentPanel.CaptureBackground;
var
canvas: TCanvas;
dc: HDC;
sourcerect: TRect;
begin
FBackground := TBitmap.Create;
with Fbackground do
begin
width := clientwidth;
height := clientheight;
end;
sourcerect.TopLeft := ClientToScreen(clientrect.TopLeft);
sourcerect.BottomRight := ClientToScreen(clientrect.BottomRight);
dc := CreateDC('DISPLAY', nil, nil, nil);
try
canvas := TCanvas.Create;
try
canvas.handle := dc;
Fbackground.Canvas.CopyRect(clientrect, canvas, sourcerect);
finally
canvas.handle := 0;
canvas.free;
end;
finally
DeleteDC(dc);
end;
end;
constructor TTransparentPanel.Create(aOwner: TComponent);
begin
inherited;
ControlStyle := controlStyle - [csSetCaption];
FBlendColor := clWhite;
FBlendAlpha := 200;
end;
destructor TTransparentPanel.Destroy;
begin
FreeAndNil(FBackground);
inherited;
end;
procedure TTransparentPanel.Paint;
begin
if csDesigning in ComponentState then
inherited
end;
procedure TTransparentPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
if (Visible) and
(HandleAllocated) and
(not (csDesigning in ComponentState)) then
begin
FreeAndNil(Fbackground);
Hide;
inherited;
Parent.Update;
Show;
end
else
inherited;
end;
procedure TTransparentPanel.WMEraseBkGnd(var msg: TWMEraseBkGnd);
var
ACanvas: TCanvas;
begin
if csDesigning in ComponentState then
inherited
else
begin
if not Assigned(FBackground) then
Capturebackground;
ACanvas := TCanvas.create;
try
ACanvas.handle := msg.DC;
ACanvas.draw(0, 0, FBackground);
ColorBlend(ACanvas, Rect(0, 0, Width, Height), FBlendColor, FBlendAlpha);
finally
FreeAndNil(ACanvas);
end;
msg.result := 1;
end;
end;
procedure TTransparentPanel.WMMove(var Message: TMessage);
begin
CaptureBackground;
end;
procedure TTransparentPanel.WMParentNotify(var Message: TWMParentNotify);
begin
CaptureBackground;
end;
procedure TTransparentPanel.ClearBackground;
begin
FreeAndNil(FBackground);
end;
procedure TTransparentPanel.ColorBlend(const ACanvas: TCanvas; const ARect: TRect;
const ABlendColor: TColor; const ABlendValue: Byte);
var
BMP: TBitmap;
begin
BMP := TBitmap.Create;
try
BMP.Canvas.Brush.Color := ABlendColor;
BMP.Width := ARect.Right - ARect.Left;
BMP.Height := ARect.Bottom - ARect.Top;
BMP.Canvas.FillRect(Rect(0,0,BMP.Width, BMP.Height));
ACanvas.Draw(ARect.Left, ARect.Top, BMP, ABlendValue);
finally
FreeAndNil(BMP);
end;
end;
procedure TTransparentPanel.SetBlendAlpha(const Value: Byte);
begin
FBlendAlpha := Value;
Paint;
end;
procedure TTransparentPanel.SetBlendColor(const Value: TColor);
begin
FBlendColor := Value;
Paint;
end;
{ TSemiModalForm }
constructor TSemiModalForm.Create(AOwner: TComponent);
begin
inherited;
FBlendColor := clWhite;
FBlendAlpha := 150;
FTransparentPanel := TTransparentPanel.Create(Self);
end;
procedure TSemiModalForm.SetFormParent(const Value: TWinControl);
begin
FFormParent := Value;
end;
procedure TSemiModalForm.ShowSemiModalForm(AForm: TForm;
SemiModalResultHandler: ISemiModalResultHandler);
begin
if FForm = nil then
begin
FForm := AForm;
FSemiModalResultHandler := SemiModalResultHandler;
FTransparentPanel.Align := alClient;
FTransparentPanel.BringToFront;
FTransparentPanel.Parent := FFormParent;
FTransparentPanel.BlendColor := FBlendColor;
FTransparentPanel.BlendAlpha := FBlendAlpha;
FTransparentPanel.OnResize := OnTransparentPanelResize;
AForm.Parent := FTransparentPanel;
FOldFormOnClose := AForm.OnClose;
AForm.OnClose := OnFormClose;
RepositionForm;
AForm.Show;
FTransparentPanel.ClearBackground;
FTransparentPanel.Visible := TRUE;
end;
end;
procedure TSemiModalForm.OnFormClose(Sender: TObject; var Action: TCloseAction);
begin
FForm.OnClose := FOldFormOnClose;
try
FForm.Visible := FALSE;
FSemiModalResultHandler.SemiModalFormClosed(FForm);
finally
FForm.Parent := nil;
FForm := nil;
FTransparentPanel.Visible := FALSE;
end;
end;
procedure TSemiModalForm.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
if (Operation = opRemove) then
begin
if AComponent = FFormParent then
SetFormParent(nil);
end;
end;
procedure TSemiModalForm.OnTransparentPanelResize(Sender: TObject);
begin
RepositionForm;
end;
procedure TSemiModalForm.RepositionForm;
begin
FForm.Left := (FTransparentPanel.Width div 2) - (FForm.Width div 2);
FForm.Top := (FTransparentPanel.Height div 2) - (FForm.Height div 2);
end;
end.
Can anybody help me with the problems or point me to an alpha blend panel that already exists?
Thanks for all your suggestions. I've taken the input and created a new component that does exactly what I need. Here's what it looks like:
The comment that pointed me in the right direction was the one by NGLN that I upvoted. If you post it as the answer I'll accept it.
I tried to add the component code to this answer, but StackOverflow wouldn't format it correctly. However, you can download the source and a full demo application here.
The component provides the following functionality:
The semi modal form is a child of the main form. This means that it
can be tabbed to just like the other controls.
The overlay area is drawn correctly with no artefacts.
The controls under the overlay area are automatically disabled.
The semi modal form/overlay can be shown/hidden if required e.g.
switching tabs.
A SemiModalResult is passed back in an event.
There are still a number of small issues that I would like to iron out. If anybody knows how to fix them, please let me know.
When the parent form is moved or resized it needs to call the
ParentFormMoved procedure. This allows the component to
resize/reposition the overlay form. Is there any way to hook into
the parent form and detect when it is moved?
If you mimimise the main form, then restore it, the overlay form appears immediately, then the main form is animated back to it's previous position. Is there a way to detect when the main form has finished animating?
The rounded corners of the semi modal window are not too pretty. I'm
not sure there's much that can be done about this as it's down to the
rectangular region.
Your code does not show the form modally, and I wonder why you would not. But then, maybe I do not understand the term semi modal.
In any case, I think the idea to create a half-transparent form on which to show the actual dialog will do just fine:
function ShowObviousModal(AForm: TForm; AParent: TWinControl = nil): Integer;
var
Layer: TForm;
begin
if AParent = nil then
AParent := Application.MainForm;
Layer := TForm.Create(nil);
try
Layer.AlphaBlend := True;
Layer.AlphaBlendValue := 128;
Layer.BorderStyle := bsNone;
Layer.Color := clWhite;
with AParent, ClientOrigin do
SetWindowPos(Layer.Handle, HWND_TOP, X, Y, ClientWidth, ClientHeight,
SWP_SHOWWINDOW);
Result := AForm.ShowModal;
finally
Layer.Free;
end;
end;
Usage:
procedure TForm1.Button1Click(Sender: TObject);
begin
FDialog := TForm2.Create(Self);
try
if ShowObviousModal(FDialog) = mrOk then
Caption := 'OK';
finally
FDialog.Free;
end;
end;
I would like a user to be able to type in the second or third word from a TComboBox item and for that item to appear in the AutoSuggest dropdown options
For example, a combo box contains the items:
Mr John Brown
Mrs Amanda Brown
Mr Brian Jones
Mrs Samantha Smith
When the user types "Br" the dropdown displays:
Mr John Brown
Mrs Amanda Brown
Mr Brian Jones
and when the user types "Jo" the dropdown displays:
Mr John Brown
Mr Brian Jones
The problem is that the AutoSuggest functionality only includes items in the dropdown list that begin with what the user has input and so in the examples above nothing will appear in the dropdown.
Is it possible to use the IAutoComplete interface and/or other related interfaces to get around this issue?
The following example uses the interposed class of the TComboBox component. The main difference from the original class is that the items are stored in the separate StoredItems property instead ofthe Items as usually (used because of simplicity).
The StoredItems are being watched by the OnChange event and whenever you change them (for instance by adding or deleting from this string list), the current filter will reflect it even when the combolist is dropped down.
The main point here is to catch the WM_COMMAND message notification CBN_EDITUPDATE which is being sent whenever the combo edit text is changed but not rendered yet. When it arrives, you just search through the StoredItems list for what you have typed in your combo edit and fill the Items property with matches.
For text searching is used the ContainsText so the search is case insensitive. Forgot to mention,the AutoComplete feature has to be turned off because it has its own, unwelcomed, logic for this purpose.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, StrUtils, ExtCtrls;
type
TComboBox = class(StdCtrls.TComboBox)
private
FStoredItems: TStringList;
procedure FilterItems;
procedure StoredItemsChange(Sender: TObject);
procedure SetStoredItems(const Value: TStringList);
procedure CNCommand(var AMessage: TWMCommand); message CN_COMMAND;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property StoredItems: TStringList read FStoredItems write SetStoredItems;
end;
type
TForm1 = class(TForm)
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
constructor TComboBox.Create(AOwner: TComponent);
begin
inherited;
AutoComplete := False;
FStoredItems := TStringList.Create;
FStoredItems.OnChange := StoredItemsChange;
end;
destructor TComboBox.Destroy;
begin
FStoredItems.Free;
inherited;
end;
procedure TComboBox.CNCommand(var AMessage: TWMCommand);
begin
// we have to process everything from our ancestor
inherited;
// if we received the CBN_EDITUPDATE notification
if AMessage.NotifyCode = CBN_EDITUPDATE then
// fill the items with the matches
FilterItems;
end;
procedure TComboBox.FilterItems;
var
I: Integer;
Selection: TSelection;
begin
// store the current combo edit selection
SendMessage(Handle, CB_GETEDITSEL, WPARAM(#Selection.StartPos),
LPARAM(#Selection.EndPos));
// begin with the items update
Items.BeginUpdate;
try
// if the combo edit is not empty, then clear the items
// and search through the FStoredItems
if Text <> '' then
begin
// clear all items
Items.Clear;
// iterate through all of them
for I := 0 to FStoredItems.Count - 1 do
// check if the current one contains the text in edit
if ContainsText(FStoredItems[I], Text) then
// and if so, then add it to the items
Items.Add(FStoredItems[I]);
end
// else the combo edit is empty
else
// so then we'll use all what we have in the FStoredItems
Items.Assign(FStoredItems)
finally
// finish the items update
Items.EndUpdate;
end;
// and restore the last combo edit selection
SendMessage(Handle, CB_SETEDITSEL, 0, MakeLParam(Selection.StartPos,
Selection.EndPos));
end;
procedure TComboBox.StoredItemsChange(Sender: TObject);
begin
if Assigned(FStoredItems) then
FilterItems;
end;
procedure TComboBox.SetStoredItems(const Value: TStringList);
begin
if Assigned(FStoredItems) then
FStoredItems.Assign(Value)
else
FStoredItems := Value;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
ComboBox: TComboBox;
begin
// here's one combo created dynamically
ComboBox := TComboBox.Create(Self);
ComboBox.Parent := Self;
ComboBox.Left := 10;
ComboBox.Top := 10;
ComboBox.Text := 'Br';
// here's how to fill the StoredItems
ComboBox.StoredItems.BeginUpdate;
try
ComboBox.StoredItems.Add('Mr John Brown');
ComboBox.StoredItems.Add('Mrs Amanda Brown');
ComboBox.StoredItems.Add('Mr Brian Jones');
ComboBox.StoredItems.Add('Mrs Samantha Smith');
finally
ComboBox.StoredItems.EndUpdate;
end;
// and here's how to assign the Items of the combo box from the form
// to the StoredItems; note that if you'll use this, you have to do
// it before you type something into the combo's edit, because typing
// may filter the Items, so they would get modified
ComboBox1.StoredItems.Assign(ComboBox1.Items);
end;
end.
This code was quite good actually, I just fixed bug with handling messages when combo is dropped down, some minor interactions with TComboBox behavior and made it a little user-friendlier. To use it just invoke InitSmartCombo after filling the Items list.
TSmartComboBox is drop in replacement for TComboBox, if you invoke InitSmartCombo it behaves as smart combo, otherwise it acts as standard TComboBox
unit SmartCombo;
interface
uses stdctrls,classes,messages,controls,windows,sysutils;
type
TSmartComboBox = class(TComboBox)
// Usage:
// Same as TComboBox, just invoke InitSmartCombo after Items list is filled with data.
// After InitSmartCombo is invoked, StoredItems is assigned and combo starts to behave as a smart combo.
// If InitSmartCombo is not invoked it acts as standard TComboBox, it is safe to bulk replace all TComboBox in application with TSmartComboBox
private
FStoredItems: TStringList;
dofilter:boolean;
storeditemindex:integer;
procedure FilterItems;
procedure StoredItemsChange(Sender: TObject);
procedure SetStoredItems(const Value: TStringList);
procedure CNCommand(var AMessage: TWMCommand); message CN_COMMAND;
protected
procedure KeyPress(var Key: Char); override;
procedure CloseUp; override;
procedure Click; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property StoredItems: TStringList read FStoredItems write SetStoredItems;
procedure InitSmartCombo;
end;
implementation
procedure TSmartComboBox.KeyPress(var Key: Char); // combo dropdown must be done in keypress, if its done on CBN_EDITUPDATE it messes up whole message processing mumbo-jumbo
begin
inherited;
if dofilter and not (ord(key) in [13,27]) then begin
if (items.Count<>0) and not droppeddown then SendMessage(Handle, CB_SHOWDROPDOWN, 1, 0) // something matched -> dropdown combo to display results
end;
end;
procedure TSmartComboBox.CloseUp; // ugly workaround for some wierd combobox/modified code interactions
var x:string;
begin
if dofilter then begin
if (items.count=1) and (itemindex=0) then text:=items[itemindex]
else if ((text<>'') and (itemindex<>-1) and (text<>items[itemindex])) or ((text='') and(itemindex=0)) then begin
storeditemindex:=itemindex;
x:=text;
itemindex:=items.indexof(text);
if itemindex=-1 then text:=x;
end
else storeditemindex:=-1;
end;
inherited;
end;
procedure TSmartComboBox.Click; // ugly workaround for some weird combobox/modified code interactions
begin
if dofilter then begin
if storeditemindex<>-1 then itemindex:=storeditemindex;
storeditemindex:=-1;
end;
inherited;
end;
procedure TSmartComboBox.InitSmartCombo;
begin
FStoredItems.OnChange:=nil;
StoredItems.Assign(Items);
AutoComplete := False;
FStoredItems.OnChange := StoredItemsChange;
dofilter:=true;
storeditemindex:=-1;
end;
constructor TSmartComboBox.Create(AOwner: TComponent);
begin
inherited;
FStoredItems := TStringList.Create;
dofilter:=false;
end;
destructor TSmartComboBox.Destroy;
begin
FStoredItems.Free;
inherited;
end;
procedure TSmartComboBox.CNCommand(var AMessage: TWMCommand);
begin
// we have to process everything from our ancestor
inherited;
// if we received the CBN_EDITUPDATE notification
if (AMessage.NotifyCode = CBN_EDITUPDATE) and dofilter then begin
// fill the items with the matches
FilterItems;
end;
end;
procedure TSmartComboBox.FilterItems;
var
I: Integer;
Selection: TSelection;
begin
// store the current combo edit selection
SendMessage(Handle, CB_GETEDITSEL, WPARAM(#Selection.StartPos), LPARAM(#Selection.EndPos));
// begin with the items update
Items.BeginUpdate;
try
// if the combo edit is not empty, then clear the items
// and search through the FStoredItems
if Text <> '' then begin
// clear all items
Items.Clear;
// iterate through all of them
for I := 0 to FStoredItems.Count - 1 do begin
// check if the current one contains the text in edit, case insensitive
if (Pos( uppercase(Text), uppercase(FStoredItems[I]) )>0) then begin
// and if so, then add it to the items
Items.Add(FStoredItems[I]);
end;
end;
end else begin
// else the combo edit is empty
// so then we'll use all what we have in the FStoredItems
Items.Assign(FStoredItems);
end;
finally
// finish the items update
Items.EndUpdate;
end;
// and restore the last combo edit selection
SendMessage(Handle, CB_SETEDITSEL, 0, MakeLParam(Selection.StartPos, Selection.EndPos));
end;
procedure TSmartComboBox.StoredItemsChange(Sender: TObject);
begin
if Assigned(FStoredItems) then
FilterItems;
end;
procedure TSmartComboBox.SetStoredItems(const Value: TStringList);
begin
if Assigned(FStoredItems) then
FStoredItems.Assign(Value)
else
FStoredItems := Value;
end;
procedure Register;
begin
RegisterComponents('Standard', [TSmartComboBox]);
end;
end.
Thanks for the heart! With a little reworking, I think that is quite right.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, StrUtils, ExtCtrls;
type
TComboBox = class(StdCtrls.TComboBox)
private
FStoredItems: TStringList;
procedure FilterItems;
procedure StoredItemsChange(Sender: TObject);
procedure SetStoredItems(const Value: TStringList);
procedure CNCommand(var AMessage: TWMCommand); message CN_COMMAND;
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property StoredItems: TStringList read FStoredItems write SetStoredItems;
end;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{}constructor TComboBox.Create(AOwner: TComponent);
begin
inherited;
AutoComplete := False;
FStoredItems := TStringList.Create;
FStoredItems.OnChange := StoredItemsChange;
end;
{}destructor TComboBox.Destroy;
begin
FStoredItems.Free;
inherited;
end;
{}procedure TComboBox.CNCommand(var AMessage: TWMCommand);
begin
// we have to process everything from our ancestor
inherited;
// if we received the CBN_EDITUPDATE notification
if AMessage.NotifyCode = CBN_EDITUPDATE then begin
// fill the items with the matches
FilterItems;
end;
end;
{}procedure TComboBox.FilterItems;
type
TSelection = record
StartPos, EndPos: Integer;
end;
var
I: Integer;
Selection: TSelection;
xText: string;
begin
// store the current combo edit selection
SendMessage(Handle, CB_GETEDITSEL, WPARAM(#Selection.StartPos), LPARAM(#Selection.EndPos));
// begin with the items update
Items.BeginUpdate;
try
// if the combo edit is not empty, then clear the items
// and search through the FStoredItems
if Text <> '' then begin
// clear all items
Items.Clear;
// iterate through all of them
for I := 0 to FStoredItems.Count - 1 do begin
// check if the current one contains the text in edit
// if ContainsText(FStoredItems[I], Text) then
if Pos( Text, FStoredItems[I])>0 then begin
// and if so, then add it to the items
Items.Add(FStoredItems[I]);
end;
end;
end else begin
// else the combo edit is empty
// so then we'll use all what we have in the FStoredItems
Items.Assign(FStoredItems)
end;
finally
// finish the items update
Items.EndUpdate;
end;
// and restore the last combo edit selection
xText := Text;
SendMessage(Handle, CB_SHOWDROPDOWN, Integer(True), 0);
if (Items<>nil) and (Items.Count>0) then begin
ItemIndex := 0;
end else begin
ItemIndex := -1;
end;
Text := xText;
SendMessage(Handle, CB_SETEDITSEL, 0, MakeLParam(Selection.StartPos, Selection.EndPos));
end;
{}procedure TComboBox.StoredItemsChange(Sender: TObject);
begin
if Assigned(FStoredItems) then
FilterItems;
end;
{}procedure TComboBox.SetStoredItems(const Value: TStringList);
begin
if Assigned(FStoredItems) then
FStoredItems.Assign(Value)
else
FStoredItems := Value;
end;
//=====================================================================
{}procedure TForm1.FormCreate(Sender: TObject);
var
ComboBox: TComboBox;
xList:TStringList;
begin
// here's one combo created dynamically
ComboBox := TComboBox.Create(Self);
ComboBox.Parent := Self;
ComboBox.Left := 8;
ComboBox.Top := 8;
ComboBox.Width := Width-16;
// ComboBox.Style := csDropDownList;
// here's how to fill the StoredItems
ComboBox.StoredItems.BeginUpdate;
try
xList:=TStringList.Create;
xList.LoadFromFile('list.txt');
ComboBox.StoredItems.Assign( xList);
finally
ComboBox.StoredItems.EndUpdate;
end;
ComboBox.DropDownCount := 24;
// and here's how to assign the Items of the combo box from the form
// to the StoredItems; note that if you'll use this, you have to do
// it before you type something into the combo's edit, because typing
// may filter the Items, so they would get modified
ComboBox.StoredItems.Assign(ComboBox.Items);
end;
end.
Added code for Unicode users.
Actually, it was only tested in Korean :(
Applied function
Prevents bugs that appear when OnExit or DropDown occurs while entering Unicode
Prevents bugs that occur when text correction or additional input after selecting an item
Modified code content
#Prevents a bug - typing values are appended when selecting a list while typing in Unicode
#Filtering is applied to each Unicode being typed if it is being entered after the end of the text.
#Exception handling in case of entering Unicode after selecting several texts
#Exception handling in case of additional input of Unicode when there is already a character in edit and the listbox is closed
Source...
unit SmartCombo;
interface
uses StdCtrls, Classes, Messages, Controls, Windows, SysUtils, StrUtils;
type
TSmartComboBox = class(TComboBox)
// Usage:
// Same as TComboBox, just invoke InitSmartCombo after Items list is filled with data.
// After InitSmartCombo is invoked, StoredItems is assigned and combo starts to behave as a smart combo.
// If InitSmartCombo is not invoked it acts as standard TComboBox, it is safe to bulk replace all TComboBox in application with TSmartComboBox
private
FChar: Char; // #for UNICODE Filter
FIgnoreChar: boolean; // #for UNICODE Edit
FStoredItems: TStringList;
doFilter: boolean;
StoredItemIndex: Integer;
procedure StoredItemsChange(Sender: TObject);
procedure SetStoredItems(const Value: TStringList);
procedure CNCommand(var AMessage: TWMCommand); message CN_COMMAND;
function GetXText(var Key: Char): string;
function GetXSelStart: Integer;
protected
procedure KeyPress(var Key: Char); override;
// #Prevents a bug - typing values are appended when selecting a list while typing in Unicode
procedure EditWndProc(var Message: TMessage); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure FilterItems;
procedure InitSmartCombo;
property StoredItems: TStringList read FStoredItems write SetStoredItems;
end;
implementation
function TSmartComboBox.GetXText(var Key: Char): string;
var
tmp: string;
begin
if (Text = '') then // empty edit box
result := ''
else if SelLength > 0 then // has selection
begin
tmp := Copy(Text, SelStart + 1, SelLength);
result := ReplaceStr(Text, tmp, '');
end
else // not empty edit box and no selection
begin
tmp := Copy(Text, 1, SelStart);
result := tmp + Key;
result := result + Copy(Text, SelStart + 1, Length(Text) - SelStart);
Key := #0;
end;
end;
function TSmartComboBox.GetXSelStart: Integer;
begin
// empty edit box or has selection
if (Text = '') or (SelLength > 0) then
result := SelStart
else // not empty edit box and no selection
result := SelStart + 1;
end;
procedure TSmartComboBox.KeyPress(var Key: Char);
// combo dropdown must be done in keypress, if its done on CBN_EDITUPDATE it messes up whole message processing mumbo-jumbo
var
xSelStart: Integer;
xText: string;
begin
inherited;
if Ord(Key) = 8 then
FChar := Key;
if doFilter and not(Ord(Key) in [8, 13, 27]) then // BackSpace, Enter, ESC
begin
FChar := Key;
if DroppedDown then
Exit;
if Items.Count = 0 then
Exit;
// backup
xSelStart := GetXSelStart;
xText := GetXText(Key);
// dropdown
SendMessage(Handle, CB_SHOWDROPDOWN, 1, 0);
if xText.IsEmpty then
Exit;
// restore
Text := xText;
SelStart := xSelStart;
end;
end;
procedure TSmartComboBox.InitSmartCombo;
begin
FStoredItems.OnChange := nil;
StoredItems.Assign(Items);
AutoComplete := False;
FStoredItems.OnChange := StoredItemsChange;
doFilter := True;
StoredItemIndex := -1;
end;
constructor TSmartComboBox.Create(AOwner: TComponent);
begin
inherited;
FStoredItems := TStringList.Create;
FIgnoreChar := False;
doFilter := False;
end;
destructor TSmartComboBox.Destroy;
begin
FStoredItems.Free;
inherited;
end;
procedure TSmartComboBox.EditWndProc(var Message: TMessage);
var
OldText: string;
begin
case Message.Msg of
WM_IME_ENDCOMPOSITION:
begin
OldText := Self.Text;
inherited;
FIgnoreChar := Self.Text = OldText;
end;
WM_CHAR:
begin
FIgnoreChar := False;
inherited;
end;
WM_IME_CHAR:
begin
if FIgnoreChar then
FIgnoreChar := False
else
inherited;
end;
else
inherited;
end;
end;
procedure TSmartComboBox.CNCommand(var AMessage: TWMCommand);
begin
// we have to process everything from our ancestor
inherited;
// #Filtering is applied to each Unicode being typed if it is being entered after the end of the text.
// #If you are typing in the middle of the text, do not apply filtering to the Unicode being typed
// (filtering is applied in units of completed Unicode characters)
if (SelStart < Length(Text)) and (FChar = #0) then
Exit;
// if we received the CBN_EDITUPDATE notification
if (AMessage.NotifyCode = CBN_EDITUPDATE) and doFilter then
begin
// fill the items with the matches
FilterItems;
end;
FChar := #0;
end;
procedure TSmartComboBox.FilterItems;
var
I: Integer;
Selection: TSelection;
begin
// store the current combo edit selection
SendMessage(Handle, CB_GETEDITSEL, WPARAM(#Selection.StartPos), LPARAM(#Selection.EndPos));
// begin with the items update
Items.BeginUpdate;
try
// if the combo edit is not empty, then clear the items
// and search through the FStoredItems
if Text <> '' then
begin
// clear all items
Items.Clear;
// iterate through all of them
for I := 0 to FStoredItems.Count - 1 do
begin
// check if the current one contains the text in edit, case insensitive
if ContainsText(FStoredItems[I], Text) then
begin
// and if so, then add it to the items
Items.Add(FStoredItems[I]);
end;
end;
end
else
begin
// else the combo edit is empty
// so then we'll use all what we have in the FStoredItems
Items.Assign(FStoredItems);
end;
finally
// finish the items update
Items.EndUpdate;
end;
// and restore the last combo edit selection
SendMessage(Handle, CB_SETEDITSEL, 0, MakeLParam(Selection.StartPos, Selection.EndPos));
end;
procedure TSmartComboBox.StoredItemsChange(Sender: TObject);
begin
if Assigned(FStoredItems) then
FilterItems;
end;
procedure TSmartComboBox.SetStoredItems(const Value: TStringList);
begin
if Assigned(FStoredItems) then
FStoredItems.Assign(Value)
else
FStoredItems := Value;
end;
end.
In handled OnDropDown event setup TComboBox items filtered by:
Pos function,
RegEx
or something even more advanced
from external full string list. Or better write your own TComboBox(TCustomComboBox) descendant.
I've modified the TLama's component and created one for my specific use case. I'm going to leave the source here if someone has similar needs.
It's basically a TComboBox which only allows it's text to be set to an actual valid value.
It behaves like a normal ComboBox with it's Style set to csDropDownList until you start typing in it. After typing, it'll search the StoredItems values and populate the Items with it.
When the component is loaded, it'll assign the Items defined in design time to the StoredItems property. Further modifications to the list in runtime have to be done using the StoredItems property.
The only issues that've found and was not able to fix is that for some reason it only works if the parent of the ComboBox is the actual form (only tested in XE2, may not be a problem in other versions).
I've added some code that pulls the ComboBox out of any nesting while keeping it's relative position, but it loses any other parenting feature.
unit uSmartCombo;
interface
uses
Vcl.StdCtrls, Classes, Winapi.Messages, Controls;
type
TSmartComboBox = class(TComboBox)
private
FStoredItems: TStringList;
procedure FilterItems;
procedure CNCommand(var AMessage: TWMCommand); message CN_COMMAND;
procedure RedefineCombo;
procedure SetStoredItems(const Value: TStringList);
procedure StoredItemsChange(Sender: TObject);
protected
procedure KeyPress(var Key: Char); override;
procedure CloseUp; override;
procedure Loaded; override;
procedure DoExit; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property StoredItems: TStringList read FStoredItems write SetStoredItems;
end;
procedure Register;
implementation
uses
SysUtils, Winapi.Windows, Vcl.Forms;
procedure Register;
begin
RegisterComponents('Standard', [TSmartComboBox]);
end;
constructor TSmartComboBox.Create(AOwner: TComponent);
begin
inherited;
FStoredItems := TStringList.Create;
FStoredItems.OnChange := StoredItemsChange;
end;
destructor TSmartComboBox.Destroy;
begin
FStoredItems.Free;
inherited;
end;
procedure TSmartComboBox.DoExit;
begin
inherited;
RedefineCombo;
end;
procedure TSmartComboBox.Loaded;
var LParent: TWinControl;
LPoint: TPoint;
begin
inherited;
if Items.Count > 0 then
FStoredItems.Assign(Items);
AutoComplete := False;
Style := csDropDownList;
// The ComboBox doesn't behave properly if the parent is not the form.
if not (Parent is TForm) then
begin
LParent := Parent;
while (not (LParent is TForm)) and Assigned(LParent) do
LParent := LParent.Parent;
LPoint := ClientToParent(Point(0,0), LParent);
Parent := LParent;
Left := LPoint.X;
Top := LPoint.Y;
BringToFront;
end;
end;
procedure TSmartComboBox.RedefineCombo;
var S: String;
begin
if Style = csDropDown then
begin
if ItemIndex <> -1 then
S := Items[ItemIndex];
Style := csDropDownList;
Items.Assign(FStoredItems);
if S <> '' then
ItemIndex := Items.IndexOf(S);
end;
end;
procedure TSmartComboBox.SetStoredItems(const Value: TStringList);
begin
if Assigned(FStoredItems) then
FStoredItems.Assign(Value)
else
FStoredItems := Value;
end;
procedure TSmartComboBox.StoredItemsChange(Sender: TObject);
begin
if Assigned(FStoredItems) then
begin
RedefineCombo;
Items.Assign(FStoredItems);
end;
end;
procedure TSmartComboBox.KeyPress(var Key: Char);
begin
if CharInSet(Key, ['a'..'z']) and not (Style = csDropDown) then
begin
DroppedDown := False;
Style := csDropDown;
end;
inherited;
if not (Ord(Key) in [13,27]) then
DroppedDown := True;
end;
procedure TSmartComboBox.CloseUp;
begin
if Style = csDropDown then
RedefineCombo;
inherited;
end;
procedure TSmartComboBox.CNCommand(var AMessage: TWMCommand);
begin
inherited;
if (AMessage.Ctl = Handle) and (AMessage.NotifyCode = CBN_EDITUPDATE) then
FilterItems;
end;
procedure TSmartComboBox.FilterItems;
var I: Integer;
Selection: TSelection;
begin
SendMessage(Handle, CB_GETEDITSEL, WPARAM(#Selection.StartPos), LPARAM(#Selection.EndPos));
Items.BeginUpdate;
Try
if Text <> '' then
begin
Items.Clear;
for I := 0 to FStoredItems.Count - 1 do
if (Pos(Uppercase(Text), Uppercase(FStoredItems[I])) > 0) then
Items.Add(FStoredItems[I]);
end
else
Items.Assign(FStoredItems);
Finally
Items.EndUpdate;
End;
SendMessage(Handle, CB_SETEDITSEL, 0, MakeLParam(Selection.StartPos, Selection.EndPos));
end;
end.