I'm to code a TExpandedShape class inherited from TShape. TExpandedShape must act like TShape and be able to draw extra shapes: Polygon and Star.
Here is my code
unit ExpandedShape;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, Windows;
type
TExpandedShapeType = (
stRectangle, stSquare, stRoundRect, stRoundSquare, stEllipse, stCircle,
stPolygon,
stStar
);
TExpandedShape = class(TShape)
private
FShape: TExpandedShapeType;
FEdgeCount: integer;
procedure SetShape(const Value: TExpandedShapeType);
procedure SetEdgeCount(const Value: integer);
public
procedure Paint; override;
published
property Shape : TExpandedShapeType read FShape write SetShape;// default stPolygon;
property EdgeCount : integer read FEdgeCount write SetEdgeCount default 5;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Course', [TExpandedShape]);
end;
// TExpandedShape
procedure TExpandedShape.Paint;
begin
case Shape of
stStar : begin {Draw Star}
end;
stPolygon : begin {Draw Polygon}
end;
else begin
{It is supposed to draw Circle, Rectangle etc, but it does not}
inherited;
end;
end;
end;
procedure TExpandedShape.SetEdgeCount(const Value: integer);
begin
FEdgeCount := Value;
Repaint;
end;
procedure TExpandedShape.SetShape(const Value: TExpandedShapeType);
begin
FShape := Value;
Repaint;
end;
end.
So, what is wrong?
IMO TShape.Paint checks private value like FShape in case section and then decides what to draw. When inherited Paint method is called in my code it checks FShape value sees default 0 value [stRectangle] in there and draws it.
PS: I did solve it with blackmagic way using Shape1 property instead of Shape one and if Shape1 value is not stPolygon or stStar i do like this: begin Shape := TShapeType(Shape1); inherited end; But this option is not really an option. I need a good short nice-looking one.
add this inherited line before your inherited....
inherited Shape := TShapeType(Shape); // ** add this line **
inherited;
Here in my web you can find an article about PlugIns in Delphi.
The sample code of the article implement a descendant class of TShape. All the code is included. You can download and see the code of class.
Another descendant classes implement figures lile Stars, Arrows,...
Here you can see some figures descendant of TShape implemented.
NeftalĂ
P.D: Excuse-me for mistakes with english.
Related
I can add a TTabItem to a TTabControl, I can add a subclass of a TTabItem to a TabControl, but I can't add a sub-subclass of a TTabItem to a TabControl.
Example Firemonkey application - a form with a TTabControl:
type
TTabItem_subclass = class (TTabItem);
TTabItem_sub_subclass = class (TTabItem_subclass);
procedure TForm1.FormCreate(Sender: TObject);
procedure add_tab (t: TTabItem);
begin
t.Text := t.ClassName;
t.Parent := TabControl1
end;
begin
add_tab (TTabItem.create (TabControl1)); // <-- works
add_tab (TTabItem_subclass.create (TabControl1)); // <-- works
add_tab (TTabItem_sub_subclass.create (TabControl1)); // <-- fails
end;
When the application is run the TTabItem_sub_subclass doesn't display:
I've tried this in both XE5 and Tokyo with the same results. What am I missing?
Short answer: I don't think you are missing anything. If fact, your code does successfully add the sub-sub-classed item to the TabControl, it just doesn't get displayed. I think this problem is caused by a flaw in the way the FMX code derives the style to be used to paint a class which is a sub-sub-class of TTabItem. I don't know enough about FMX to idemtify the exact cause of the problem, but I have identified what seems to be a functional work-around.
Please see the code below of a sample project which successfully displays both
TabItem subClass and TabItem sub_subClass tabs.
The reason the code is structured as it is is to make it easy to set a changed-memory breakpoint on
the FResourceLink field of the TabItem (the variable Item in the code), while I was
trying to trace how the painting process occurs.
From watching the TabItem.Paint method, it was obvious that the tab would only paint
if its FResourceLink is not nil. The problem with your original code (and mine)
was that when Paint is called on TabItem_subClass, its FResourceLink has been assigned
a value whereas for TabItem_sub_subClass it has not. Evidently the FResourceLink
is where it picks up the name of the style used to paint the TabItem and if
it can't be found the TabItem doesn't get painted.
I'm afraid that as I'm no expert in FMX I find its code something of a labyrinth
at the best of times and its implementation of styles even more so. But it
struck me that if I could ensure that a valid style name is returned for
the TabItem GetParentClassStyleLookupName metod, that should suffice. That's the reason
for the TCustomItem_sub_subclass.GetParentClassStyleLookupName override. I imagine
an FMX expert might see it as a bit of a sledgehammer to crack a walnut, but there
you go.
Code
type
TForm1 = class(TForm)
TabControl1: TTabControl;
StyleObject1: TStyleObject; // ignore this
procedure FormCreate(Sender: TObject);
private
public
Item : TTabItem;
end;
[...]
implementation
[...]
type
TCustomItem_subclass = class (TTabItem)
public
constructor Create(AOwner : TComponent); override;
end;
TCustomItem_sub_subclass = class (TCustomItem_subclass)
public
constructor Create(AOwner : TComponent); override;
function GetParentClassStyleLookupName: string; override;
end;
procedure TForm1.FormCreate(Sender: TObject);
procedure add_tab (t: TTabItem);
begin
t.Text := t.ClassName;
t.Parent := TabControl1
end;
begin
{$define UseSubSub}
{$ifdef UseSubSub}
Item := TCustomItem_sub_subclass.Create(TabControl1);
{$else}
Item := TCustomItem_subclass.Create(TabControl1);
{$endif}
Item.Text := Item.ClassName;
Item.Parent := TabControl1;
Caption := TabControl1.ActiveTab.Text;
Item := TCustomItem_subclass.Create(TabControl1);
Item.Text := Item.ClassName;
Item.Parent := TabControl1;
end;
constructor TCustomItem_subclass.Create(AOwner: TComponent);
begin
inherited;
end;
constructor TCustomItem_sub_subclass.Create(AOwner: TComponent);
begin
inherited;
end;
function TCustomItem_sub_subclass.GetParentClassStyleLookupName: string;
begin
Result := 'tabitemstyle';
end;
Btw, in doing this I noticed what seems to be a lurking bug in the function
TStyledControl.GenerateStyleName(const AClassName: string): string in FMX.Controls.Pas'
If the AClassName argument, stripped of a leading TCustom, starts with a double-TT,
as in TCustomTabItem, the code incorrectly removes the T of TabItem. I didn't have
time or energy to explore this further but it's why my TabItem sub-classes omit
the Tab from their names.
I'm trying to create a custom property editor for some custom component. The custom property editor is intended to edit some set property, like
type
TButtonOption = (boOption1, boOption2, boOption3);
TButtonOptions = set of TButtonOption;
my property editor descends from TSetProperty class. The problem is: my custom property editor doesn't get registered and Delphi IDE seems to use its own default set property editor, because ShowMessage() calls inside property editor methods never executes! I've created a sample package/component from scratch, as simple as possible, showing this issue. Here is the code:
unit Button1;
interface
uses
System.SysUtils, System.Classes, Vcl.Controls, Vcl.StdCtrls, DesignIntf, DesignEditors;
type
TButtonOption = (boOption1, boOption2, boOption3);
TButtonOptions = set of TButtonOption;
TButtonEx = class(TButton)
private
FOptions: TButtonOptions;
function GetOptions: TButtonOptions;
procedure SetOptions(Value: TButtonOptions);
published
property Options: TButtonOptions read GetOptions write SetOptions default [];
end;
TMySetProperty = class(TSetProperty)
public
function GetAttributes: TPropertyAttributes; override;
procedure GetProperties(Proc: TGetPropProc); override;
function GetValue: string; override;
end;
procedure Register;
implementation
uses
Dialogs;
// TButtonEx - sample component
function TButtonEx.GetOptions: TButtonOptions;
begin
Result := FOptions;
end;
procedure TButtonEx.SetOptions(Value: TButtonOptions);
begin
if FOptions <> Value then
begin
FOptions := Value;
end;
end;
// register stuff
procedure Register;
begin
RegisterComponents('Samples', [TButtonEx]);
RegisterPropertyEditor(TypeInfo(TButtonOptions), nil, '', TMySetProperty);
end;
function TMySetProperty.GetAttributes: TPropertyAttributes;
begin
ShowMessage('GetAttributes');
Result := inherited GetAttributes;
end;
procedure TMySetProperty.GetProperties(Proc: TGetPropProc);
begin
ShowMessage('GetProperties');
inherited;
end;
function TMySetProperty.GetValue: string;
begin
ShowMessage('GetValue');
Result := inherited GetValue;
end;
end.
Please note that:
I'm registering the new property editor (TMySetProperty) for ALL components having a TButtonOptions property. I also tried to do it for TButtonEx only, but the result is the same.
I've added ShowMessage() calls inside all overriden methods of my custom property editor and those methods NEVER get called.
I've already debugged the package and RegisterPropertyEditor() executes. Nevertheless, my custom code in overridden methods never execute.
I've seen other 3rd party components using such property editor (TSetProperty descendants) running in older Delphi IDEs and I could not find any relevant difference in code. Maybe Delphi XE2+ requires something else?
So the question is:
Why my custom property editor does not register/work?
Note: This issue happens in Delphi XE2, XE3, XE4 and also XE5 at least. Other IDEs were not tested but probably have the same behavior.
Finally I got a solution... After testing everything I could imagine - without success - I started searching for something "new" in DesignEditors.pas and DesignIntf.pas units. Reading GetEditorClass() function, I discovered that it first checks for a PropertyMapper. A property mapper can be registered using RegisterPropertyMapper() function. Using it instead of RegisterPropertyEditor() works just as expected. Here is my modified, working code, also showing some interesting application for this: show or hide some options of my set-based property, based on some criteria:
unit Button1;
interface
uses
System.SysUtils, System.Classes, Vcl.Controls, Vcl.StdCtrls,
DesignIntf, DesignEditors;
type
TButtonOption = (boOptionA, boOptionB, boOptionC);
TButtonOptions = set of TButtonOption;
type
TButtonEx = class(TButton)
private
FOptions: TButtonOptions;
function GetOptions: TButtonOptions;
procedure SetOptions(Value: TButtonOptions);
published
property Options: TButtonOptions read GetOptions write SetOptions default [];
end;
TMySetProperty = class(TSetProperty)
private
FProc: TGetPropProc;
procedure InternalGetProperty(const Prop: IProperty);
public
procedure GetProperties(Proc: TGetPropProc); override;
end;
procedure Register;
implementation
uses
TypInfo;
// TButtonEx - sample component
function TButtonEx.GetOptions: TButtonOptions;
begin
Result := FOptions;
end;
procedure TButtonEx.SetOptions(Value: TButtonOptions);
begin
if FOptions <> Value then
begin
FOptions := Value;
end;
end;
// Returns TMySetProperty as the property editor used for Options in TButtonEx class
function MyCustomPropMapper(Obj: TPersistent; PropInfo: PPropInfo): TPropertyEditorClass;
begin
Result := nil;
if Assigned(Obj) and (Obj is TButtonEx) and SameText(String(PropInfo.Name), 'Options') then begin
Result := TMySetProperty;
end;
end;
procedure Register;
begin
RegisterComponents('Samples', [TButtonEx]);
// RegisterPropertyEditor does not work for set-based properties.
// We use RegisterPropertyMapper instead
RegisterPropertyMapper(MyCustomPropMapper);
end;
procedure TMySetProperty.GetProperties(Proc: TGetPropProc);
begin
// Save the original method received
FProc := Proc;
// Call inherited, but passing our internal method as parameter
inherited GetProperties(InternalGetProperty);
end;
procedure TMySetProperty.InternalGetProperty(const Prop: IProperty);
var
i: Integer;
begin
if not Assigned(FProc) then begin // just in case
Exit;
end;
// Now the interesting stuff. I just want to show boOptionA and boOptionB in Object inspector
// So I call the original Proc in those cases only
// boOptionC still exists, but won't be visible in object inspector
for i := 0 to PropCount - 1 do begin
if SameText(Prop.GetName, 'boOptionA') or SameText(Prop.GetName, 'boOptionB') then begin
FProc(Prop); // call original method
end;
end;
end;
end.
I have noticed, in Delphi XE6 (and in other tools/languages that produce applications that run on Windows, and use native GDI font rendering) that the Win32 TextOut API does not seem to smooth any font larger than 149, that is, the Font.Size>149. Here is a screenshot showing two SpeedButtons, both with Font.Quality set to fqClearType, the one on the left Font.Size is set to 149, the one on the right is set with Font.Size is 150. That's one point difference. The height values are -199 and -200 respectively. This is simply to demonstrate with a Delphi component and form, what could also be demonstrated in a TPaintBox, with use of a Canvas.Font and a call to Win32 API DrawText, or with a pure Win32 API application that creates a window, and draws to a device context using DrawText.
The limitation of GDI is shown clearly here; Note that ClearType looks mediocre (horizontal anti-aliasing but no vertical) at size=149 , and ClearType turns off completely at 150:
My question is, is there any way to circumvent this limitation in the Win32 API GDI, using some raw Win32 function available on Windows 7 and up, to draw the text and always anti-alias? I assume here that logical font handling is being done properly, inside the VCL, because the same limit occurs in a C# application (using WinForms, which runs atop GDI) as I see when I try this in Delphi.
I would like to draw an anti-aliased character with a font size greater than 149, to a GDI canvas, either with Clear Type or with classic Anti-Aliasing. How would I do that?
Note that I have already set Font.Quality explicitly to both AntiAliased and ClearType modes, and that Win32 GDI api calls ignore these logical font properties about a certain size, apparently by design. Certain applications like Microsoft Word, however clearly have font-rendering capability to draw a 155 point font or larger, and still anti-alias in this case.
Update: I answered my own question showing how easy DirectWrite+GDI interop is. On windows 7 and windows 8, and later, DirectWrite actually provides both horizontal and vertical anti-aliasing, and I believe this is high quality on-screen font rendering mode is what apps like MS Word 2013 are using. I believe that someone could easily answer my question showing a GDI+ sample, and that would also fit my requirements above (as GDI+ is included in Windows 7 and 8).
A working approach that I have found that interoperates with GDI better than GDI+ does is to use DirectWrite, BUT THIS WORKS ONLY in Windows 7 and 8, and the sample code I present here has a simple GDI fallback mode (plain GDI, no anti-aliasing) that covers XP and Vista, to provide at least a graceful degradation; it still paints text on pre-Win7 operating systems, using GDI.
The original demo app is here, but it was using TForm which I changed to TWinControl, and it had no GDI fallback, just an exception.
http://cc.embarcadero.com/item/27491
The discussion/blog post by Pawel Glowacki who wrote the above demo is here:
http://blogs.embarcadero.com/pawelglowacki/2009/12/14/38872
A code snippet including a modified D2DUtils.pas from Pawel's demo with addition of a GDI fall-back feature (instead of blowing up with an exception) is shown here.
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
Winapi.D2D1,
Vcl.Direct2D;
type
TCanvasD2D = class(TWinControl) // a base class, using TWinControl instead of TForm.
private
FInitFlag: Boolean;
FGDIMode: Boolean; { Fallback }
FD2DCanvas: TDirect2DCanvas; { Used When D2D is available and GDIMode=False }
FGDICanvas: TCanvas; { Fallback canvas, used when FGDIMode=True }
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure Resize; override;
procedure DoPaint(AHDC: HDC); virtual;
procedure CreateD2DResources; virtual;
procedure PaintD2D; virtual;
procedure PaintGDI; virtual;
function RenderTarget: ID2D1RenderTarget; // convenience function used during D2D Paints.
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Init;
property D2DCanvas: TDirect2DCanvas read FD2DCanvas;
property GDICanvas: TCanvas read FGDICanvas;
property GDIMode: Boolean read FGDIMode write FGDIMode;
{ Set to true to force GDI fallback, will automatically set true if D2D is not available, also }
end;
TCanvasD2DSample = class(TCanvasD2D) // subclass of TCanvasD2D that is a primitive "TLabel"
private
FFontBrush: ID2D1SolidColorBrush;// Brush generated from current value of FFontColor
FBackgroundColor:TColor; // clWhite
FFontColor:TColor; //clBlack;
FTextFormat: IDWriteTextFormat;
FFontName: string;
FFontSize: Integer; { Units?}
FDisplayText: String;
FLocale: String;
procedure SetFontName(const Value: String);
procedure SetFontSize(const Value: Integer);
procedure SetDisplayText(const Value: String);
protected
procedure PaintD2D; override;
procedure PaintGDI; override;
procedure CreateD2DResources; override;
function FontSizeToDip(FontSize:Integer ):Double;
public
constructor Create(AOwner: TComponent); override;
property TextFormat:IDWriteTextFormat read FTextFormat;
property FontSize:Integer read FFontSize write SetFontSize;
property FontName:String read FFontName write SetFontName;
property DisplayText: String read FDisplayText write SetDisplayText;
property BackgroundColor:TColor read FBackgroundColor write FBackgroundColor;
property FontColor:TColor read FFontColor write FFontColor; //clBlack;
property Locale: String read FLocale write FLocale; // string like 'en-us'
end;
implementation
constructor TCanvasD2D.Create(AOwner: TComponent);
begin
inherited;
end;
destructor TCanvasD2D.Destroy;
begin
FD2DCanvas.Free;
FD2DCanvas := nil;
FGDICanvas.Free;
FGDICanvas := nil;
inherited;
end;
procedure TCanvasD2D.Init;
begin
if not FInitFlag then
begin
FInitFlag := True;
if (not FGDIMode) and (TDirect2DCanvas.Supported) then
begin
if Assigned(FD2DCanvas) then
FD2DCanvas.Free;
FD2DCanvas := TDirect2DCanvas.Create(Handle);
CreateD2DResources;
end
else
begin
FGDIMode := True;
if Assigned(FGDICanvas) then
FGDICanvas.Free;
FGDICanvas := TCanvas.Create;
FGDICanvas.Handle := GetDC(Self.Handle);
end;
end;
end;
procedure TCanvasD2D.CreateD2DResources;
begin
// create Direct2D resources in descendant class
end;
function TCanvasD2D.RenderTarget: ID2D1RenderTarget;
begin
Result := D2DCanvas.RenderTarget;
end;
procedure TCanvasD2D.Resize;
var
HwndTarget: ID2D1HwndRenderTarget;
ASize: TD2D1SizeU;
begin
inherited;
if Assigned(D2DCanvas) then
if Supports(RenderTarget, ID2D1HwndRenderTarget, HwndTarget) then
begin
ASize := D2D1SizeU(ClientWidth, ClientHeight);
HwndTarget.Resize(ASize);
end;
Invalidate;
end;
procedure TCanvasD2D.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
if (not FGDIMode) then
// avoid flicker as described here:
// http://chrisbensen.blogspot.com/2009/09/touch-demo-part-i.html
Message.Result := 1
else
inherited;
end;
procedure TCanvasD2D.DoPaint(AHDC: HDC);
begin
Init;
if FGDIMode then
begin
FGDICanvas.Handle := AHDC;
PaintGDI;
end
else
begin
D2DCanvas.BeginDraw;
try
PaintD2D;
finally
D2DCanvas.EndDraw;
end;
end;
end;
procedure TCanvasD2D.PaintD2D;
begin
// implement painting code in descendant class
end;
procedure TCanvasD2D.PaintGDI;
begin
// implement in descendant.
end;
procedure TCanvasD2D.PaintWindow(DC: HDC);
begin
DoPaint(DC);
inherited;
end;
{ Custom Control Subclass }
procedure TCanvasD2DSample.CreateD2DResources;
begin
inherited;
D2DCanvas.RenderTarget.CreateSolidColorBrush(
D2D1ColorF(FFontColor, 1),
nil,
FFontBrush
);
DWriteFactory.CreateTextFormat(
PWideChar(FontName),
nil,
DWRITE_FONT_WEIGHT_REGULAR,
DWRITE_FONT_STYLE_NORMAL,
DWRITE_FONT_STRETCH_NORMAL,
FontSizeToDip( FontSize),
PWideChar(FLocale),
FTextFormat
);
FTextFormat.SetTextAlignment(DWRITE_TEXT_ALIGNMENT_CENTER);
FTextFormat.SetParagraphAlignment(DWRITE_PARAGRAPH_ALIGNMENT_CENTER);
end;
function TCanvasD2DSample.FontSizeToDip(FontSize: Integer): Double;
begin
result := FontSize * (96.0 / 72.0); { TODO: 96.0 should not be hard coded? }
end;
procedure TCanvasD2DSample.PaintD2D;
var
aRect: TD2D1RectF;
// ASize:D2D_SIZE_F;
begin
// fill with white color the whole window
RenderTarget.Clear(D2D1ColorF(FBackgroundColor));
RenderTarget.DrawText(
PWideChar(FDisplayText),
Length(FDisplayText),
FTextFormat,
D2D1RectF(0, 0, ClientWidth, ClientHeight),
FFontBrush
);
// RenderTarget.GetSize(ASize);
end;
procedure TCanvasD2DSample.PaintGDI;
begin
{ FALLBACK PAINT MODE}
GDICanvas.Lock;
GDICanvas.Font.Name := FFontName;
GDICanvas.Font.Size := FFontSize;
GDICanvas.Font.Color := FFontColor;
GDICanvas.Brush.Style := bsSolid;
GDICanvas.Brush.Color := FBackgroundColor;
GDICanvas.Rectangle(Self.ClientRect);
GDICanvas.TextOut(0,0, FDisplayText);
GDICanvas.Unlock;
end;
procedure TCanvasD2DSample.SetDisplayText(const Value: String);
begin
if Value<>FDisplayText then
begin
FDisplayText := Value;
Invalidate;
end;
end;
procedure TCanvasD2DSample.SetFontName(const Value: String);
begin
FFontName := Value;
end;
procedure TCanvasD2DSample.SetFontSize(const Value: Integer);
begin
FFontSize := Value;
end;
I was looking for an easy way to use RichtText in a default combobox, but found nothing.
So I wrote this little Delphi(7) component, that is working so far.
How is works:
I'm calling "init" to replace the "Edit"-window inside a default combobox with a
runtime-created RichEdit. Size is taken from the Edit, and Edit is finally hidden.
Some event-handlers are included for change-detection and so on.
Problem:
If I click an item of the dropdown-list, the text is shown in the RichEdit.
If some text is entered inside the RichEdit and the dropdown-button is pressed again,
the dropdown-list is opened and closed in the next moment. After some clicks, the list
remains open and is working as expected.
Every time I click the list and change the RichEdit again, the same is happening.
Maybe I have to sent some messages to the combobox to get that fixed ?
I didn't find any solution on the web, so far. Maybe you have an idea.
Thanks for your help !
unit RichTextComboBox;
interface
uses SysUtils, Classes, Controls, StdCtrls, Windows, Messages, forms, Graphics, ComCtrls;
type
TRichTextComboBox = class(TComboBox)
private
FOnChange :TNotifyEvent;
EditHandle :Integer;
procedure proc_FOnComboChange(Sender: TObject);
protected
public
Rich :TRichEdit; // accessable from outside
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Init; // replace Edit in combobox with RichEdit
published
end;
procedure Register;
implementation
constructor TRichTextComboBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
end;
// click in Combo-Drop-Down-List
procedure TRichTextComboBox.proc_FOnComboChange(Sender :TObject);
begin
if Rich.Text <> Items.Strings[ItemIndex] then begin
Rich.Text:= Items.Strings[ItemIndex];
end;
if assigned (FOnChange) then FOnChange(sender);
end;
procedure Register;
begin
RegisterComponents('TEST', [tRichTextComboBox]);
end;
destructor TRichTextComboBox.Destroy;
begin
if Rich <> nil then begin
RemoveControl(rich);
Rich.destroy;
end;
inherited Destroy;
end;
// Replace "Edit" with "RichEdit" in ComboBox
//
procedure TRichTextComboBox.init;
var h :integer;
rect :trect;
wndpos :TWindowPlacement;
begin
h:= FindWindowEx(
self.Handle,
0, // handle to a child window
'Edit', // class name
nil
);
Rich:= TRichEdit.create(self);
rich.Parent:= self;
if h <> 0 then begin
EditHandle:= h;
GetWindowRect(h, rect);
// configure RichEdit
GetWindowPlacement(h, #wndpos); // RichEdit with position and size of Edit
rich.BorderStyle:= bsNone;
rich.Text:= self.Text;
rich.Font.Style:= [fsbold, fsItalic];
rich.Top:= wndpos.rcNormalPosition.top;
rich.Left:= wndpos.rcNormalPosition.Left;
rich.Width:= rect.Right - rect.Left;
rich.Height:= rect.Bottom-rect.Top;
rich.WantReturns:= false; // just one line
rich.WordWrap:= false; // just one line
rich.ParentColor:= true; // just one line
rich.Visible:= true;
showwindow(h, sw_hide); // hide Edit
end;
// if drop-down-combo-list is clicked
// change the string of the RichEdit
FOnChange:= self.OnChange; // save original OnChange of ComboBox
rich.OnChange:= FOnChange;
self.OnChange:= proc_FOnComboChange;
end;
end.
Finally I found the solution :-)
The RichEdit is holding the Focus, which causes the drop-down-list not to stay open after entering s.th. in the RichEdit.
This procedure sets the Focus back to the Combobox before it is opening. So everything works as expected.
Code to be inserted:
after protected enter:
procedure DropDown; override;
the procedure looks like this:
procedure TRichTextComboBox.DropDown;
begin
Self.SetFocus;
inherited DropDown;
end;
I prefer this approach, because I don't want to mess around with the OwnerDraw-problems that we can read on many pages. (Some things are still missing: Upkey/Downkey...)
I got quite a large application which is currently being styled up.
To save me changing all the buttons in the IDE/Object Inspector I am planning on just doing a few functions for the main objects like
procedure StyleButton(AButton : TButton)
begin
AButton.Color := clGreen;
AButton.Font.Style = [fsBold];
end;
etc etc and then add that to the forms onCreates as needed
StyleButton(Button1); whatever etc
There is no issue passing objects in params like this. It does just reference the first object right?
It works fine and I can't think of any issues, but because this is a large application which thousands of users I just want to be sure there will be no issues/memory leaks/resource consumpution issues.
Will also be doing similar things with TAdvStringGrid and TEdit/TMemo components.
Then allows just 1 place to change these settings.
Or someone have a better idea?
This is an excellent idea. The function will modify whichever object you pass to it.
You are not passing by reference. You are passing by value. The value you are passing is a reference. "Passing by reference" means you'd use the var or out keywords, which are not appropriate in this situation.
Your idea is just fine, as the other answerers have already said. Just want to propose a solution that goes even further than David's and something you may want to consider in order to avoid having to add many statements like:
StyleButton(Button1);
StyleButton(Button2);
to each and every form for each and every control you would like to style;
What I would propose is to add a single method call to for example each form's OnShow event:
procedure TForm1.FormShow(Sender: TObject);
begin
TStyler.StyleForm(Self);
end;
The TStyler could be implemented in a separate unit that looks like this:
interface
type
TStyler = class;
TStylerClass = class of TStyler;
TStyler = class(TObject)
public
class procedure StyleForm(const aForm: TCustomForm);
class procedure StyleControl(const aControl: TControl); virtual;
class function GetStyler(const aControl: TControl): TStylerClass;
end;
implementation
uses
Contnrs;
type
TButtonStyler = class(TStyler)
public
class procedure StyleControl(const aControl: TControl); override;
end;
TEditStyler = class(TStyler)
public
class procedure StyleControl(const aControl: TControl); override;
end;
TLabelStyler = class(TStyler)
public
class procedure StyleControl(const aControl: TControl); override;
end;
var
_Controls: TClassList;
_Stylers: TClassList;
{ TStyler }
class function TStyler.GetStyler(const aControl: TControl): TStylerClass;
var
idx: Integer;
begin
Result := TStyler;
idx := _Controls.IndexOf(aControl.ClassType);
if idx > -1 then
Result := TStylerClass(_Stylers[idx]);
end;
class procedure TStyler.StyleForm(const aForm: TCustomForm);
procedure _StyleControl(const aControl: TControl);
var
i: Integer;
StylerClass: TStylerClass;
begin
StylerClass := TStyler.GetStyler(aControl);
StylerClass.StyleControl(aControl);
if (aControl is TWinControl) then
for i := 0 to TWinControl(aControl).ControlCount - 1 do
_StyleControl(TWinControl(aControl).Controls[i]);
end;
var
i: Integer;
begin
_StyleControl(aForm);
end;
class procedure TStyler.StyleControl(const aControl: TControl);
begin
// Do nothing. This is a catch all for all controls that do not need specific styling.
end;
{ TButtonStyler }
class procedure TButtonStyler.StyleControl(const aControl: TControl);
begin
inherited;
if aControl is TButton then
begin
TButton(aControl).Font.Color := clRed;
TButton(aControl).Font.Style := [fsBold];
end;
end;
{ TEditStyler }
class procedure TEditStyler.StyleControl(const aControl: TControl);
begin
inherited;
if aControl is TEdit then
begin
TEdit(aControl).Color := clGreen;
end;
end;
{ TLabelStyler }
class procedure TLabelStyler.StyleControl(const aControl: TControl);
begin
inherited;
if aControl is TLabel then
begin
TLabel(aControl).Font.Color := clPurple;
TLabel(aControl).Font.Style := [fsItalic];
end;
end;
initialization
_Controls := TClassList.Create;
_Stylers := TClassList.Create;
_Controls.Add(TButton);
_Stylers.Add(TButtonStyler);
_Controls.Add(TEdit);
_Stylers.Add(TEditStyler);
_Controls.Add(TLabel);
_Stylers.Add(TLabelStyler);
finalization
FreeAndNiL(_Controls);
FreeAndNiL(_Stylers);
end.
This solution basically employs polymorphism and a registry that links control classes to styler classes. It also uses class procedures and functions to avoid having to instantiate anything.
Please note that the registry is implemented in this example as two lists that need to be kept in sync manually as the code assumes that finding a class at index X will find the styler at the same index in the other list. This can of course be improved upon very much, but is sufficient here to show the concept.
No, There is no issue (in your specific case) passing a object as parameter
procedure StyleButton(AButton : TButton)
when you do this you are passing a address memory (reference) and setting some properties of the referenced object, so there is not problem.
To add to what Rob and RRUZ have already said, you could consider an extra helper using open array parameters:
procedure StyleButtons(const Buttons: array of TButton);
var
i: Integer;
begin
for i := low(Buttons) to high(Buttons) do
StyleButton(Buttons[i]);
end;
You can then call this as:
StyleButtons([btnOK, btnCancel, btnRelease64bitDelphi]);
which is, in my view, more readable at the call-site than:
StyleButton(btnOK);
StyleButton(btnCancel);
StyleButton(btnRelease64bitDelphi);
Note that I passed the open array as a const parameter because that is more efficient when dealing with arrays. Because each element of the array is itself a reference to the button, you are able to modify the actual button. The const just means that you cannot change the reference.