Adding Canvas to TScrollBox - delphi

I am trying to do simple thing: Add a Canvas property on the TScrollBox descendant. I have read this article
but my ScrollBox descendant simply does not draw on the canvas. May anybody tell me, what is wrong?
TfrmScrollContainer = class (TScrollBox)
private
FCanvas: TCanvas;
FControlState:TControlState;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
protected
procedure Paint;
procedure PaintWindow(DC: HDC); override;
property Canvas: TCanvas read FCanvas;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
... this is exact copy, how TWincontrol turns to TCustomControl (but it fails somewhere)
constructor TfrmScrollContainer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TControlCanvas.Create;
TControlCanvas(FCanvas).Control := Self;
end;
destructor TfrmScrollContainer.Destroy;
begin
FCanvas.Free;
inherited Destroy;
end;
procedure TfrmScrollContainer.WMPaint(var Message: TWMPaint);
begin
Include(FControlState, csCustomPaint);
inherited;
Exclude(FControlState, csCustomPaint);
end;
procedure TfrmScrollContainer.PaintWindow(DC: HDC);
begin
FCanvas.Lock;
try
FCanvas.Handle := DC;
try
TControlCanvas(FCanvas).UpdateTextFlags;
Paint;
finally
FCanvas.Handle := 0;
end;
finally
FCanvas.Unlock;
end;
end;
procedure TfrmScrollContainer.Paint; // this is not executed (I do not see any ellipse)
begin
Canvas.Brush.Color:=clRed;
Canvas.Ellipse(ClientRect);
end;
Thanx

You are not including csCustomPaint to ControlState, you're including it to the similarly named field you declared. Your field is not checked, the ascendant control does not know anything about it. To solve, replace
procedure TfrmScrollContainer.WMPaint(var Message: TWMPaint);
begin
Include(FControlState, csCustomPaint);
inherited;
Exclude(FControlState, csCustomPaint);
end;
with
procedure TfrmScrollContainer.WMPaint(var Message: TWMPaint);
begin
ControlState := ControlState + [csCustomPaint];
inherited;
ControlState := ControlState - [csCustomPaint];
end;
Alternatively your scroll box may parent any control for your custom painting to work. The inherited WM_PAINT handler checks to see the control count and if it's not 0 it calls the paint handler instead of delivering the message to the default handler.

Related

How can I avoid a form getting focus when dragged

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.

Propagate Event from internal component

I'm writing a component that include few components.
TMyComponent = class(TPanel)
private
fGrid : TExCustomDBGrid;
fOnCellClick : TDBGridClickEvent;
public
constructor Create(AOwner: TComponent); override;
published
property OnCellClick: TDBGridClickEvent read FOnCellClick write FOnCellClick;
End;
...
constructor TMyComponent .Create(AOwner: TComponent);
begin
inherited;
fGrid := TExCustomDBGrid.Create(self);
fGrid.parent := self;
fGrid.Align := alClient;
end;
I want to be able to propagate the Event from the component (TPanel), to the fGrid included.
How can I reach that goal ?
I guess I should declare an Event with the same type on the TPanel (as container component). Then how to propagate into the fGrid ?
It's a bit unclear what you're asking, but based on the code I see, write an event handler and assign it to the grid...
procedure TMyComponent.DBGridCellClicked(Column: TColumn);
begin
if Assigned(fOnCellClick) then
fOnCellClick(Column);
end;
constructor TMyComponent.Create(AOwner: TComponent);
begin
inherited;
fGrid := TExCustomDBGrid.Create(self);
fGrid.Parent := self;
fGrid.Align := alClient;
fGrid.OnCellClick := DBGridCellClicked;
end;

Using TFrame, how do I properly access the TCanvas property just as in a TForm?

I need to draw on the frames Canvas at runtime just like you would do with a normal form but for some reason they decided not to add the Canvas property to the frame even tho both TCustomFrame and TCustomForm come from the same parent class that handles the Canvas.
I've made it work up to the part where I can draw something by overriding the PaintWindow procedure but I still can't seem to use the Canvas property at runtime as if I'm missing a big chunk of the code.
Here's what I've done up to now :
TCustomFrameEx = class(TCustomFrame)
private
FCanvas: TControlCanvas;
function GetCanvas: TCanvas;
public
property Canvas: TCanvas read GetCanvas;
end;
TFrame = class(TCustomFrameEx)
protected
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy(); override;
published
...
end;
constructor TFrame.Create(AOwner: TComponent);
begin
inherited;
FCanvas := TControlCanvas.Create();
end;
destructor TFrame.Destroy();
begin
FreeAndNil(fCanvas);
inherited;
end;
function TCustomFrameEx.GetCanvas : TCanvas;
begin
Result := fCanvas;
end;
procedure TFrame.PaintWindow(DC: HDC);
begin
inherited;
FCanvas.Handle := DC;
FCanvas.Control := Self;
FCanvas.Brush.Color := clWhite;
fCanvas.FillRect(GetClientRect);
FCanvas.Handle := 0;
end;
I assume I'm not properly assigning the handle or missing some paint event?
The easiest way would be
procedure TFrame2.PaintWindow(DC: HDC);
Var
c:TCanvas;
begin
inherited;
c := Tcanvas.Create;
try
c.Handle := DC;
c.Brush.Color := clWhite;
c.FillRect(GetClientRect);
c.Brush.Color := clBlue;
//c.Ellipse(0,0,200,200);
finally
c.Free;
end;
end;
The PaintWindow method of a frame is only called if the frame has children. You'll need to add a paint box control (or similar) to your frame, or some children (perhaps invisible).

Why the composite component fails to parent controls?

I created my own Component : TPage , which Contains Subcomponent TPaper (TPanel).
The problem is, that when I put controls such as TMemo or TButton on the TPaper (which fills up nearly whole area), the controls do not load at all. see example below
TPaper = class(TPanel)
protected
constructor Create(AOwner: TComponent);override;
destructor Destroy;override;
public
procedure Paint; override;
end;
TPage = class(TCustomControl)
private
FPaper:TPaper;
protected
procedure CreateParams(var Params:TCreateParams); override;
public
constructor Create(AOwner: TComponent);override;
destructor Destroy;override;
published
property Paper: TPaper read FPaper write FPaper;
end;
constructor TPage.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
PaperOrientation:=poPortrait;
PaperSize:=psA4;
PaperBrush:=TBrush.Create;
PaperBrush.Color:=clWhite;
PDFDocument:=Nil;
FPaper:=TPaper.Create(Self);
FPaper.Parent:=Self;
FPaper.SetSubComponent(True);
end;
...
Memo1 is parented in TPaper (TPanel) at design-time, but after
pressing "Run" it does not exist.
procedure TForm1.btn1Click(Sender: TObject);
begin
if not Assigned(Memo1) then ShowMessage('I do not exist'); //Memo1 is nil
end;
Have you any idea what's wrong?
Thanks a lot
P.S Delphi 7
When I put TMemo inside TPaper and save the unit (Unit1), after inspection of associated dfm file, there is no trace of TMemo component. (Thats why it can not load to app.)
Serge is right. Delphi only streams components that are owned by the Form they reside in. In order to avoid the EClassNotfound Exception, which occurs during reading of the form file (You should now at least see a Tpaper component in your dfm file) you must register the class by using the RegisterClass function (in the unit Classes). A good place for this would be in the initialisation section of your unit.
If setting the owner of Tpaper to a Form is not an option, then you can still get Delphi to stream your subcomponents by overriding the Getchildren and GetChildOwner methods and applying the logic TCustomForm uses:
TPage = class
...
public
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
function GetChildOwner:TComponent; override;
end;
procedure TPage.GetChildren(Proc: TGetChildProc; Root: TComponent); // this is copied
var // from
I: Integer; // TCustomForm
OwnedComponent: TComponent;
begin
inherited GetChildren(Proc, Root);
if Root = Self then
for I := 0 to ComponentCount - 1 do
begin
OwnedComponent := Components[I];
if not OwnedComponent.HasParent then Proc(OwnedComponent);
end;
end;
function TPage.GetChildOwner: TComponent;
begin
inherited;
Result:=Self;
end;
The question is 5 years ago, but because I came across the same problem and could not find a workable solution in the network decided to share what I found as a solution after much testing.
TClientPanel = class(TCustomControl)
private
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
public
constructor Create(AOwner: TComponent); override;
end;
TMainPanel = class(TCustomControl)
private
FClient: TClientPanel;
protected
function GetChildOwner: TComponent; override;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
procedure ReadState(Reader: TReader); override;
procedure CreateComponentEvent(Reader: TReader; ComponentClass: TComponentClass; var Component: TComponent);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
...
end;
constructor TClientPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible];
end;
procedure TClientPanel.WMNCHitTest(var Message: TWMNCHitTest);
begin
if not (csDesigning in ComponentState) then
Message.Result := HTTRANSPARENT
else
inherited;
end;
var
TClientPanel_Registered: Boolean = False;
constructor TMainPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FClient := TClientPanel.Create(Self);
FClient.Parent := Self;
FClient.Align := alClient;
Exclude(FComponentStyle, csInheritable);
if not TClientPanel_Registered then
begin
RegisterClasses([TClientPanel]);
TClientPanel_Registered := True;
end;
end;
destructor TMainPanel.Destroy;
begin
FClient.Free;
inherited Destroy;
end;
function TMainPanel.GetChildOwner: TComponent;
begin
Result := Self;
end;
procedure TMainPanel.GetChildren(Proc: TGetChildProc; Root: TComponent);
begin
Proc(TControl(FClient));
end;
procedure TMainPanel.CreateComponentEvent(Reader: TReader; ComponentClass: TComponentClass; var Component: TComponent);
begin
if ComponentClass.ClassName = 'TClientPanel' then Component := FClient;
end;
procedure TMainPanel.ReadState(Reader: TReader);
begin
Reader.OnCreateComponent := CreateComponentEvent;
inherited ReadState(Reader);
Reader.OnCreateComponent := nil;
end;
Not very professional, but I hope it will help :^)
P.S. just did a quick test (XE5), but basically works.

CueText equivalent for a TMemo

I have this Delphi code to set the cue text of a control on my form:
procedure TfrmMain.SetCueText(edt: TWinControl; cueText: string);
const
ECM_FIRST = $1500;
EM_SETCUEBANNER = ECM_FIRST + 1;
begin
SendMessage(edt.Handle,EM_SETCUEBANNER,0,
LParam(PWideChar(WideString(cueText))));
end;
I want the same effect on a TMemo, but the MSDN document says:
You cannot set a cue banner on a
multiline edit control or on a rich
edit control.
Is there a standard way to have a cuetext effect on a TMemo, or do I have to fiddle with the OnEnter/OnExit events and roll my own?
You can hack the TMemo Control
TMemo With TextHint Single Line Version
type
TMemo = class(StdCtrls.TMemo)
private
FTextHint: string;
FTextHintFont: TFont;
protected
FCanvas : TCanvas;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
published
property TextHint: string read FTextHint write FTextHint;
property TextHintFont: TFont read FTextHintFont write FTextHintFont;
end;
TForm1 = class(TForm)
Memo1: TMemo;
private
public
end;
constructor TMemo.Create(AOwner: TComponent);
begin
inherited;
FCanvas := TControlCanvas.Create;
FTextHintFont := TFont.Create;
FTextHintFont.Color := clGrayText;
TControlCanvas(FCanvas).Control := Self;
end;
destructor TMemo.Destroy;
begin
FreeAndNil(FTextHintFont);
FreeAndNil(FCanvas);
inherited;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
begin
inherited;
if (Text = '') and (not Focused) then
begin
FCanvas.Font := FTextHintFont;
FCanvas.TextOut(1, 1, FTextHint); //Note : is not multiline
end;
end;
To set the TextHint property
Memo1.TextHint:='Enter your comments here';
TMemo With TextHint MultiLine Version
type
TMemo = class(StdCtrls.TMemo)
private
FTextHint: TStrings;
FTextHintFont: TFont;
protected
FCanvas : TCanvas;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
published
property TextHint: TStrings read FTextHint write FTextHint;
property TextHintFont: TFont read FTextHintFont write FTextHintFont;
end;
constructor TMemo.Create(AOwner: TComponent);
begin
inherited;
FTextHint := TStringList.Create;
FCanvas := TControlCanvas.Create;
FTextHintFont := TFont.Create;
FTextHintFont.Color := clGrayText;
TControlCanvas(FCanvas).Control := Self;
end;
destructor TMemo.Destroy;
begin
FreeAndNil(FTextHintFont);
FreeAndNil(FCanvas);
FTextHint.Clear;
FreeAndNil(FTextHint);
inherited;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
Var
i : integer;
TextHeight : Integer;
begin
inherited;
if (Text = '') and (not Focused) then
begin
FCanvas.Font := FTextHintFont;
TextHeight:=FCanvas.TextHeight('MLZ'); //Dummy Text to determine Height
for i := 0 to FTextHint.Count - 1 do
FCanvas.TextOut(1, 1+(i*TextHeight), FTextHint[i]);
end;
end;
Memo1.TextHint.Add('Enter your comments here Line 1');
Memo1.TextHint.Add('Enter your comments here Line 2');
Memo1.TextHint.Add('Enter your comments here Line 3');
Bye.

Resources