I have a check box control with a labeled edit as a published subcomponent.
What I'm trying to do is create a Translate procedure for the check box that would show the labeled edit on top, and allow the user to change the text of the check box's caption. Something like this:
constructor TPBxCheckBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTranslateEdit := TLabeledEdit.Create(Self);
FTranslateEdit.Parent := Self.Parent;
FTranslateEdit.SetSubComponent(True);
FTranslateEdit.Visible := False;
end;
procedure TPBxCheckBox.Translate(Show: Boolean);
begin
TranslateEdit.Left := Self.Left;
TranslateEdit.Top := Self.Top;
TranslateEdit.EditLabel.Caption := Self.Caption;
TranslateEdit.Text := Self.Caption;
TranslateEdit.Visible := Show;
TranslateEdit.Width := Self.Width;
end;
But this doesn't work - the labeled edit is never shown.
What am I doing wrong here?
It doesn't show because at TPBxCheckBox.Create() time Parent isn't yet assigned, so you're basically doing TranslateEdit.Parent := nil;.
If you really want your TranslatedEdit to have the same parent as the TPBxCheckBox itself, you could override SetParet and take action at the moment TPBxCheckBox's Parent is Assigned. Something like this:
TPBxCheckBox = class(TWhatever)
protected
procedure SetParent(AParent: TWinControl); override;
end;
procedure TPBxCheckBox.SetParent(AParent: TWinControl);
begin
inherited;
TranslatedEdit.Parent := AParent;
end;
When I make components with multiple parts I have not used the SetSubComponent method.
What I have done is something like this
constructor TPBxCheckBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTranslateEdit := TLabeledEdit.Create(Self);
FTranslateEdit.Parent := Self;
FTranslateEdit.Visible := False;
end;
And I would try something like this
procedure TPBxCheckBox.Translate(Show: Boolean);
begin
FTranslateEdit.EditLabel.Caption := Self.Caption;
FTranslateEdit.Left := Self.Left;
FTranslateEdit.Top := Self.Top;
FTranslateEdit.Width := Self.Width;
FTranslateEdit.Height := Self.Height;
FTranslateEdit.Text := Self.Caption;
FTranslateEdit.Visible := Show;
end;
I'll improve this answer if you get me more information or if I get time to test this out.
Related
Using some answers in StackOverflow I've created a searcheable TComboBox in Delphi. It works fine when you add it directly to a Form, but breaks as soon as you add it to a TPanel and I can't seem to figure out why.
Directly on the form:
After typing t:
Inside a panel:
After typing t:
Here is the component's code:
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.
// Workaround to pull it from any parenting
//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.
Any help in how I can proceed to figure out why this is happening would be greatly appreciated!
Edit 1:
After doing some extra debugging, I've noticed the messages being sent to the ComboBox differ from the ones inside the panel.
A CBN_EDITUPDATE is never sent, like #Sherlock70 mentioned in the comments, which makes the FilterItems procedure never trigger.
I've also noticed the form behaves strangely after using the ComboBox inside the panel, sometimes freezing and even not responding, like it gets stuck in a loop.
This unpredictable behavior has made me move away from this approach, and I'm probably going to take an alternate route to create a "searchable ComboBox".
Going to leave the question open if someone wants to figure it out and maybe even use the component.
I hope this will help someone in future even after 7 months of the question. Setting the style of a Combobox will destroy the window handle of that Combobox and create a new one. This means windows will free your control's Window Handle and create a new one.
You are setting your Combobx style while searching and this is wrong. Try removing Style := from your code and test it again you will get the same results for Combobox on a form and Combobox on a panel or other TWinControl. As you can see in the following code, setting Style will call RecreateWnd.
procedure TCustomComboBox.SetStyle(Value: TComboBoxStyle);
begin
if FStyle <> Value then
begin
FStyle := Value;
if Value = csSimple then
ControlStyle := ControlStyle - [csFixedHeight] else
ControlStyle := ControlStyle + [csFixedHeight];
RecreateWnd;
end;
end;
RecreateWnd will call DestroyHandle()
procedure TWinControl.CMRecreateWnd(var Message: TMessage);
var
WasFocused: Boolean;
begin
WasFocused := Focused;
DestroyHandle;
UpdateControlState;
if WasFocused and (FHandle <> 0) then Windows.SetFocus(FHandle);
end;
Then DestroyHandle will call DestroyWnd() which will call DestroyWindowHandle().
I have a set of TImage instances layed out on a panel. The TImages represent icons (see attached screenshot). I would like to draw a red rectangle around a given TImage instance when the user selects it by clicking on it. Not sure how to proceed...
Edit: why am I not using a TToolbar? Reason 1: I don't like the default "look and feel" of the TToolbar and I want to have more control on it. Reason 2: This control is not really a TToolbar. It should rather be considered as a sort of "bookmark" element, which displays different text in the memo field depending on which "bookmark" is selected.
The accepted solution using Remy Lebeau's suggestion is shown below:
I would suggest using a TPaintBox instead of a TImage. Load your image into an appropriate TGraphic class (TBitmap, TIcon, TPNGImage, etc) and then draw it onto the TPaintBox in its OnPaint event. That is all a TImage really does (it holds a TGraphic that is drawn onto its Canvas when painted). You can then draw a red rectangle on top of the image when needed. For example:
procedure TMyForm.PaintBox1Click(Sender: TObject);
begin
PaintBox1.Tag := 1;
PaintBox1.Invalidate;
PaintBox2.Tag := 0;
PaintBox2.Invalidate;
end;
procedure TMyForm.PaintBox2Click(Sender: TObject);
begin
PaintBox1.Tag := 0;
PaintBox1.Invalidate;
PaintBox2.Tag := 1;
PaintBox2.Invalidate;
end;
procedure TMyForm.PaintBox1Paint(Sender: TObject);
begin
PaintBox1.Canvas.Draw(MyImage1, 0, 0);
if PaintBox1.Tag = 1 then
begin
PaintBox1.Canvas.Brush.Style := bsClear;
PaintBox1.Canvas.Pen.Color := clRed;
PaintBox1.Canvas.Rectangle(PaintBox1.ClientRect);
end;
end;
procedure TMyForm.PaintBox2Paint(Sender: TObject);
begin
PaintBox2.Canvas.Draw(MyImage2, 0, 0);
if PaintBox2.Tag = 1 then
begin
PaintBox2.Canvas.Brush.Style := bsClear;
PaintBox2.Canvas.Pen.Color := clRed;
PaintBox2.Canvas.Rectangle(PaintBox2.ClientRect);
end;
end;
Alternatively, you can derive a new class from TImage and override its virtual Paint() method to draw the rectangle after default drawing. For example:
type
TMyImage = class(TImage)
private
FShowRectangle: Boolean;
procedure SetShowRectangle(Value: Boolean);
protected
procedure Paint; override;
public
property ShowRectangle: Boolean read FShowRectangle write SetShowRectangle;
end;
procedure TMyImage.SetShowRectangle(Value: Boolean);
begin
if FShowRectangle <> Value then
begin
FShowRectangle := Value;
Invalidate;
end;
end;
type
TGraphicControlAccess = class(TGraphicControl)
end;
procedure TMyImage.Paint;
begin
inherited;
if FShowRectangle then
begin
with TGraphicControlAccess(Self).Canvas do
begin
Brush.Style := bsClear;
Pen.Color := clRed;
Rectangle(ClientRect);
end;
end;
end;
procedure TMyForm.MyImage1Click(Sender: TObject);
begin
MyImage1.ShowRectangle := true;
MyImage2.ShowRectangle := false;
end;
procedure TMyForm.MyImage2Click(Sender: TObject);
begin
MyImage1.ShowRectangle := false;
MyImage2.ShowRectangle := true;
end;
I would modify the proposals. there would be no problem with the objects on the form type the following :
TImage = class(ExtCtrls.TImage)
private
FShowRectangle: Boolean;
procedure SetShowRectangle(Value: Boolean);
protected
procedure Paint; override;
public
property ShowRectangle: Boolean read FShowRectangle write SetShowRectangle;
end;
I would recommend using a TRectangle. You can add an bitmap (bitmap, jpg, etc) via the Fill propery and set the Stroke property for the border.
You also can set the xRadius and yRadius properties for rounded borders.
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 am working on a Delphi component which consists of a panel with some labels and buttons. It can look like this:
or like this:
depending on the setting of a property. Also, the layout of the labels changes depending on the length of the first one.
I have been prototyping this with a TFrame, and doing the layout calculations in the OnPaint method of the frame. What is the right place to do this in a component based on a TPanel? Or, more precisely, in a TCustomAdvPanel, which is what I'm deriving from. Does it work in an override for the Paint method, like so?
procedure TDateRangePicker.Paint;
const
hSpacing = 5;
begin
if FShowRefresh then
begin
btnRefresh.Visible := true;
btnRefresh.Left := Width - hSpacing - btnRefresh.Width;
btnClearDates.Left := btnRefresh.Left - hSpacing - btnClearDates.Width;
btnChooseDates.Left := btnClearDates.Left - hSpacing - btnChooseDates.Width;
end
else begin
btnRefresh.Visible := false;
btnClearDates.Left := Width - hSpacing - btnClearDates.Width;
btnChooseDates.Left := btnClearDates.Left - hSpacing - btnChooseDates.Width;
end;
lblRangeCaption.Left := hSpacing;
lblDateRange.Left := lblRangeCaption.Left + lblRangeCaption.Width + hSpacing;
inherited Paint;
end;
Definitely do not use the Paint method to re-position controls. In the worst case this keeps on triggering the Paint method again, and again... because, well: due to replacing controls, the panel needs to get repainted. Paint, and all equivalents, is only meant for drawing yourself.
On whén to implement your code: this should be done in the setter of the ShowRefresh property.
On how to implement your ShowRefresh property: of course you can move the controls around like you are doing now. You also might consider using Margins (Delphi XE) and aligning the buttons and labels. Then the property setters will become rather simple:
type
TDateRangePicker = class(TCustomPanel)
private
FChooseButton: TButton;
FClearButton: TButton;
FRefreshButton: TButton;
FLabel1: TLabel;
FLabel2: TLabel;
function GetLabel1Caption: String;
function GetRefreshButtonVisible: Boolean;
procedure SetLabel1Caption(const Value: String);
procedure SetRefreshButtonVisible(Value: Boolean);
public
constructor Create(AOwner: TComponent); override;
published
property RefreshButtonVisible: Boolean read GetRefreshButtonVisible
write SetRefreshButtonVisible default True;
property Label1Caption: String read GetLabel1Caption
write SetLabel1Caption;
end;
...
constructor TDateRangePicker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FChooseButton := TButton.Create(Self);
FChooseButton.Caption := 'Choose';
FChooseButton.Align := alRight;
FChooseButton.AlignWithMargins := True;
FChooseButton.Margins.Left := 10;
FChooseButton.Parent := Self;
FClearButton := TButton.Create(Self);
FClearButton.Caption := 'Clear';
FClearButton.Align := alRight;
FClearButton.AlignWithMargins := True;
FClearButton.Margins.Left := 10;
FClearButton.Parent := Self;
FRefreshButton := TButton.Create(Self);
FRefreshButton.Caption := 'Refresh';
FRefreshButton.Align := alRight;
FRefreshButton.AlignWithMargins := True;
FRefreshButton.Margins.Left := 10;
FRefreshButton.Parent := Self;
FLabel1 := TLabel.Create(Self);
FLabel1.Caption := 'Foo caption: ';
FLabel1.Align := alLeft;
FLabel1.Layout := tlCenter;
FLabel1.Parent := Self;
FLabel2 := TLabel.Create(Self);
FLabel2.Caption := 'From 03/08/2012 to 06/06/2012';
FLabel2.Align := alLeft;
FLabel2.Layout := tlCenter;
FLabel2.Parent := Self;
end;
function TDateRangePicker.GetLabel1Caption: String;
begin
Result := FLabel1.Caption;
end;
function TDateRangePicker.GetRefreshButtonVisible: Boolean;
begin
Result := FRefreshButton.Visible;
end;
procedure TDateRangePicker.SetLabel1Caption(const Value: String);
begin
FLabel1.Caption := Value;
end;
procedure TDateRangePicker.SetRefreshButtonVisible(Value: Boolean);
begin
FRefreshButton.Visible := Value;
FRefreshButton.Left := Width;
end;
And the testing routine:
procedure TMainForm.TestButtonClick(Sender: TObject);
begin
DateRangePicker1.Label1Caption := 'Test: ';
DateRangePicker1.RefreshButtonVisible := not DateRangePicker1.RefreshButtonVisible;
end;
You can create a property for TDateRangePicker like :
property ShowRefresh:boolean read GetShowRefresh write SetShowRefresh
procedure TDateRangePicker.SetShowRefresh( Value : boolean);
begin
btnRefresh.Visible := Value;
// Force autosize after hidding Refresh button
Autosize := True;
end;
So, you have nothing to do during the drawing.
You set the intial positions when you create the child controls, and then update the positions at the time you need to update them (when changing the property, when the Parent component is resized, etc). You MUST NOT changing the positions inside the Paint() method or OnPaint event.
If you are using a modern version of Delphi, you should instead make use of the Align, Margins, and AlignWithMargins properties of the child controls. That way, you just position the controls one time at the time you create them, and let the VCL do all the hard work of repositioning them automatically when it needs to.
How to dim / fade all other windows of an application in Delphi 2009.
Form has an AlphaBlend property, but it controls only transparency level. But it would be nice if we can have something like this
(Concentrated window) . Even stackoverflow.com does that, when we try to insert a link/ image etc in the post.
How can we achieve this in a delphi application?
Here is a unit I just knocked together for you.
To use this unit drop a TApplication component on your main form and in the OnModalBegin call _GrayForms and then in the OnModalEnd call the _NormalForms method.
This is a very simple example and could be made to be more complex very easily. Checking for multiple call levels etc....
For things like system (open, save, etc) dialogs you can wrap the dialog execute method in a try...finally block calling the appropriate functions to get a similar reaction.
This unit should work on Win2k, WinXP, Vista and should even work on Win7.
Ryan.
unit GrayOut;
interface
procedure _GrayForms;
procedure _GrayDesktop;
procedure _NormalForms;
implementation
uses windows, classes, forms, Contnrs, Types, Graphics, sysutils;
var
gGrayForms : TComponentList;
procedure _GrayDesktop;
var
loop : integer;
wScrnFrm : TForm;
wForm : TForm;
wPoint : TPoint;
begin
if not assigned(gGrayForms) then
begin
gGrayForms := TComponentList.Create;
gGrayForms.OwnsObjects := true;
for loop := 0 to Screen.MonitorCount - 1 do
begin
wForm := TForm.Create(nil);
gGrayForms.Add(wForm);
wForm.Position := poDesigned;
wForm.AlphaBlend := true;
wForm.AlphaBlendValue := 64;
wForm.Color := clBlack;
wForm.BorderStyle := bsNone;
wForm.Enabled := false;
wForm.BoundsRect := Screen.Monitors[loop].BoundsRect;
SetWindowPos(wForm.handle, HWND_TOP, 0,0,0,0, SWP_NOSIZE or SWP_NOMOVE);
wForm.Visible := true;
end;
end;
end;
procedure _GrayForms;
var
loop : integer;
wScrnFrm : TForm;
wForm : TForm;
wPoint : TPoint;
wScreens : TList;
begin
if not assigned(gGrayForms) then
begin
gGrayForms := TComponentList.Create;
gGrayForms.OwnsObjects := true;
wScreens := TList.create;
try
for loop := 0 to Screen.FormCount - 1 do
wScreens.Add(Screen.Forms[loop]);
for loop := 0 to wScreens.Count - 1 do
begin
wScrnFrm := wScreens[loop];
if wScrnFrm.Visible then
begin
wForm := TForm.Create(wScrnFrm);
gGrayForms.Add(wForm);
wForm.Position := poOwnerFormCenter;
wForm.AlphaBlend := true;
wForm.AlphaBlendValue := 64;
wForm.Color := clBlack;
wForm.BorderStyle := bsNone;
wForm.Enabled := false;
wForm.BoundsRect := wScrnFrm.BoundsRect;
SetWindowLong(wForm.Handle, GWL_HWNDPARENT, wScrnFrm.Handle);
SetWindowPos(wForm.handle, wScrnFrm.handle, 0,0,0,0, SWP_NOSIZE or SWP_NOMOVE);
wForm.Visible := true;
end;
end;
finally
wScreens.free;
end;
end;
end;
procedure _NormalForms;
begin
FreeAndNil(gGrayForms);
end;
initialization
gGrayForms := nil;
end.
I have done something similar for showing a modal form trying to keep the implementation as simple as possible. I don't know if this will fit your needs, but here it is:
function ShowModalDimmed(Form: TForm; Centered: Boolean = true): TModalResult;
var
Back: TForm;
begin
Back := TForm.Create(nil);
try
Back.Position := poDesigned;
Back.BorderStyle := bsNone;
Back.AlphaBlend := true;
Back.AlphaBlendValue := 192;
Back.Color := clBlack;
Back.SetBounds(0, 0, Screen.Width, Screen.Height);
Back.Show;
if Centered then begin
Form.Left := (Back.ClientWidth - Form.Width) div 2;
Form.Top := (Back.ClientHeight - Form.Height) div 2;
end;
result := Form.ShowModal;
finally
Back.Free;
end;
end;
I'm not sure about the "right" way to do it, but in order to "fade-to-white", what you can do is place your form in another completely white form (white background color, no controls).
So when your form is in 0% transparency, it will show as a regular form, but when it's in 50% transparency it will be faded to white. You can obviously choose other colors as your background.
I'm looking forward to seeing other answers...
EDIT: after seeing your "Jedi Concentrate" link, it seems that a dark-gray background will mimic the Expose effect better.
One way to do this is to place another form behind your dialog, this form would have no borders, and would contain a single image. This image would be a capture of the entire desktop from just before the dialog popped up, then run through a transform to lower the luminosity of each pixel by 50%. One trick that works quite well here is to use a black form, and to only include ever other pixel. If you know for certain that you will have theme support, you can optionally use a completely black form and use the alphablend and alphablendvalue properties..this will allow the OS to perform the luminosity transformation for you. An alphablendvalue of 128 is = 50%.
EDIT
As mghie pointed out, there is the possibility of a user pressing alt-tab to switch to another application. One way to handle this scenario would be to hide the "overlay" window in the application.OnDeactivate event, and to show it on the application.OnActivate event. Just remember to set the zorder of the overlay window lower than your modal dialog.
I created a similar effect to the Jedi Concentrate with a Form sized to the Screen.WorkArea with Color := clBlack and BorderStyle := bsNone
I found setting the AlphaBlendValue was too slow to animate nicely, so I use SetLayeredWindowAttributes()
The unit's code:
unit frmConcentrate;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TFadeThread = class(TThread)
private
fForm: TForm;
public
constructor Create(frm: TForm);
procedure Execute; override;
end;
TConcentrateFrm = class(TForm)
procedure FormDestroy(Sender: TObject);
procedure FormClick(Sender: TObject);
private
{ Private declarations }
fThread: TFadeThread;
public
{ Public declarations }
end;
procedure StartConcentrate(aForm: TForm = nil);
var
ConcentrateFrm: TConcentrateFrm;
implementation
{$R *.dfm}
procedure StartConcentrate(aForm: TForm = nil);
var
Hnd: HWND;
begin
try
if not Assigned(ConcentrateFrm) then
ConcentrateFrm := TConcentrateFrm.Create(nil)
else
Exit;
ConcentrateFrm.Top := Screen.WorkAreaTop;
ConcentrateFrm.Left := Screen.WorkAreaLeft;
ConcentrateFrm.Width := Screen.WorkAreaWidth;
ConcentrateFrm.Height := Screen.WorkAreaHeight;
Hnd := GetForegroundWindow;
SetWindowLong(ConcentrateFrm.Handle, GWL_EXSTYLE,
GetWindowLong(ConcentrateFrm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED
);
SetLayeredWindowAttributes(
ConcentrateFrm.Handle,
ColorToRGB(clBlack),
0,
LWA_ALPHA
);
ConcentrateFrm.Show;
if Assigned(aForm) then
aForm.BringToFront
else
SetForegroundWindow(Hnd);
ConcentrateFrm.fThread := TFadeThread.Create(ConcentrateFrm);
Application.ProcessMessages;
ConcentrateFrm.fThread.Resume;
except
FreeAndNil(ConcentrateFrm);
end;
end;
procedure TConcentrateFrm.FormClick(Sender: TObject);
var
p: TPoint;
hnd: HWND;
begin
GetCursorPos(p);
ConcentrateFrm.Hide;
hnd := WindowFromPoint(p);
while GetParent(hnd) 0 do
hnd := GetParent(hnd);
SetForegroundWindow(hnd);
Release;
end;
procedure TConcentrateFrm.FormDestroy(Sender: TObject);
begin
ConcentrateFrm := nil;
end;
{ TFadeThread }
constructor TFadeThread.Create(frm: TForm);
begin
inherited Create(true);
FreeOnTerminate := true;
Priority := tpIdle;
fForm := frm;
end;
procedure TFadeThread.Execute;
var
i: Integer;
begin
try
// let the main form open before doing this intensive process.
Sleep(300);
i := 0;
while i < 180 do
begin
if not Win32Check(
SetLayeredWindowAttributes(
fForm.Handle,
ColorToRGB(clBlack),
i,
LWA_ALPHA
)
) then
begin
RaiseLastOSError;
end;
Sleep(10);
Inc(i, 4);
end;
except
end;
end;
end.