Transparent TMemo - text appears to remain selected when it isn't - delphi

I was hoping for some help with regards to a transparent TMemo control in Delphi 7. I found some code online that works well, to an extent, the refresh rate is a bit rubbish but I can live with that. The main problem is that unselected text can look as if it's actually selected.
Here's where all the text is selected using SelectAll();
Here's where no text is actually selected, but has been previously, note the floating line suggesting typing will happen after the 'p' in Improvement.
And finally an image just showing the difference.
What I find quite odd is that if I hit an arrow key for example, the false highlighting disappears, but when using the mouse it does not.
The code for this custom TMemo is as follows:
unit TrMemo;
interface
uses
Messages, Controls, StdCtrls, classes;
const TMWM__SpecialInvalidate=WM_USER+1111;
type
TTransparentMemo = class(TMemo)
private
procedure SpecialInvalidate(var Message:TMessage); message TMWM__SpecialInvalidate;
procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
procedure WMSetText(var Message:TWMSetText); message WM_SETTEXT;
procedure CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT); message CN_CTLCOLOREDIT;
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
protected
procedure CreateParams(var Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
end;
procedure Register;
implementation
uses Windows;
{ TTransparentMemo }
procedure TTransparentMemo.WMHScroll(var Message: TWMHScroll);
begin
inherited;
PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;
procedure TTransparentMemo.WMVScroll(var Message: TWMVScroll);
begin
SendMessage(Handle,TMWM__SpecialInvalidate,0,0);
inherited;
PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;
procedure TTransparentMemo.CNCTLCOLOREDIT(var Message:TWMCTLCOLOREDIT);
begin
with Message do
begin
SetBkMode(ChildDC,TRANSPARENT);
Result:=GetStockObject(HOLLOW_BRUSH)
end
end;
procedure TTransparentMemo.WMSetText(var Message:TWMSetText);
begin
inherited;
if not (csDesigning in ComponentState) then PostMessage(Handle,TMWM__SpecialInvalidate,0,0)
end;
procedure TTransparentMemo.SpecialInvalidate(var Message:TMessage);
var
r:TRect;
begin
if (Parent <> nil) then
begin
r:=ClientRect;
r.TopLeft:=Parent.ScreenToClient(ClientToScreen(r.TopLeft));
r.BottomRight:=Parent.ScreenToClient(ClientToScreen(r.BottomRight));
InvalidateRect(Parent.Handle,#r,true);
RedrawWindow(Handle,nil,0,RDW_FRAME+RDW_INVALIDATE);
end;
end;
procedure TTransparentMemo.WMKeyDown(var Message: TWMKeyDown);
begin
SendMessage(Handle,TMWM__SpecialInvalidate,0,0);
inherited;
PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
end;
procedure TTransparentMemo.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result:=1
end;
constructor TTransparentMemo.Create(AOwner: TComponent);
begin
inherited;
ControlStyle:=[csCaptureMouse, csDesignInteractive, csClickEvents, csSetCaption, csOpaque, csDoubleClicks, csReplicatable, csNoStdEvents];
end;
procedure TTransparentMemo.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
begin
ExStyle:=ExStyle or WS_EX_TRANSPARENT and not WS_EX_WINDOWEDGE
and not WS_EX_STATICEDGE and not WS_EX_DLGMODALFRAME and not
WS_EX_CLIENTEDGE;
end;
end;
procedure Register;
begin
RegisterComponents('Samples', [tTransparentMemo]);
end;
end.
Any tips/hints/answers would be greatly appreciated! Cheers in advance!

This isn't a complete fix, but you could, for example, do something like
protected
procedure Click; override;
procedure TTransparentMemo.Click;
begin
PostMessage(Handle,TMWM__SpecialInvalidate,0,0);
inherited;
end;
And so on. Perhaps there's a better place to do this. Have a look in your VCL source (StdCtrls.pas) and you might find something in TCustomEdit or TCustomMemo which would be better options to override.

Related

Synchronize 5 ListBoxes together

im working on a little Project right now and i want to synchronize 5 listBoxes scrolling together. The names of the listboxes are:
KidList
PointList
NoteList
CommentList
CommentListKid
How can i do it?
You could try the following technique.
First, add a private field
private
SyncBoxes: TArray<TListBox>;
to your form and initialise it when the form is created:
procedure TForm1.FormCreate(Sender: TObject);
begin
SyncBoxes := [ListBox1, ListBox2, ListBox3, ListBox4];
end;
Then define the following interposer class:
type
TListBox = class(Vcl.StdCtrls.TListBox)
strict private
procedure Sync;
protected
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
procedure WMMouseWheel(var Message: TWMMouseWheel); message WM_MOUSEWHEEL;
end;
implemented as
procedure TListBox.CNCommand(var Message: TWMCommand);
begin
inherited;
if Message.NotifyCode = LBN_SELCHANGE then
Sync;
end;
procedure TListBox.Sync;
var
LB: TListBox;
begin
for LB in Form1.SyncBoxes do
if LB <> Self then
LB.TopIndex := Self.TopIndex;
end;
procedure TListBox.WMMouseWheel(var Message: TWMMouseWheel);
begin
inherited;
Sync;
end;
procedure TListBox.WMVScroll(var Message: TWMVScroll);
begin
inherited;
Sync;
end;
Of course, in a real app you would refactor this.
The result is possibly good enough:
The list box's scrolling animation makes synchronisation a little bit delayed, however.

How to override the call to show the CapsLock hint window in a TEdit?

Basically I have this problem: CapsLock password message in TEdit visually fails with VCL Styles.
What I want to do is not to solve the problem as shown in the answer or the comments.
I want to disable that ugly hint window entirely. and instead show an image letting the user know that the caps are locked.
like this
I found the solution to my problem, It involves a hack that I would rather not use.
It goes like this.
Override WndProc.
code
type
TEdit = class (Vcl.StdCtrls.TEdit)
protected
procedure WndProc(var Message: TMessage); override;
end;
Intercept the EM_SHOWBALLOONTIPmessage and you are done
code
procedure TEdit.WndProc(var Message: TMessage);
begin
if Message.Msg = EM_SHOWBALLOONTIP then
showmessage('Do your thing.')
else
inherited;
end;
For more information check the MSDN documentation:
How do I suppress the CapsLock warning on password edit controls?
This is a descendant of TEdit that would allow to suppress the CapsLock warning on password edit controls, if a certain FOnPasswordCaps events are assigned with PasswordChar <> #0
unit NCREditUnit;
interface
uses
Vcl.StdCtrls,
vcl.Controls,
Winapi.Messages,
System.Classes;
type
TNCREdit = class(TEdit)
private
FOnPasswordCapsLocked: TNotifyEvent;
FIsCapsLocked: boolean;
FOnPasswordCapsFreed: TNotifyEvent;
FBlockCapsBalloonTip: boolean;
FValuePasswordChrOnCaps: boolean;
procedure SetOnPasswordCapsEvents;
procedure SetOnPasswordCapsFreed(const aValue: TNotifyEvent);
procedure SetOnPasswordCapsLocked(const aValue: TNotifyEvent);
protected
procedure WndProc(var Message: TMessage); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure DoEnter; override;
procedure DoExit; override;
published
property BlockCapsBalloonTip: boolean read FBlockCapsBalloonTip write FBlockCapsBalloonTip default False;
property ValuePasswordChrOnCaps: boolean read FValuePasswordChrOnCaps write FValuePasswordChrOnCaps default True;
//... The usual property declaration of TEdit
property OnPasswordCapsLocked: TNotifyEvent read FOnPasswordCapsLocked write SetOnPasswordCapsLocked;
property OnPasswordCapsFreed: TNotifyEvent read FOnPasswordCapsFreed write SetOnPasswordCapsFreed;
end;
implementation
uses
Winapi.CommCtrl,
Winapi.Windows;
{ TNCREdit }
procedure TNCREdit.DoEnter;
begin
inherited;
if FBlockCapsBalloonTip then
begin
FIsCapsLocked := Odd(GetKeyState(VK_CAPITAL));
SetOnPasswordCapsEvents;
end;
end;
procedure TNCREdit.DoExit;
begin
if FBlockCapsBalloonTip and (FIsCapsLocked) then
begin
FIsCapsLocked := False;
SetOnPasswordCapsEvents;
end;
inherited;
end;
procedure TNCREdit.KeyUp(var Key: Word; Shift: TShiftState);
begin
if Key = VK_CAPITAL then
FIsCapsLocked := not FIsCapsLocked;
SetOnPasswordCapsEvents;
inherited;
end;
procedure TNCREdit.SetOnPasswordCapsEvents;
begin
if FIsCapsLocked then
begin
if Assigned(FOnPasswordCapsLocked) and
((self.PasswordChar <> #0) or ( not FValuePasswordChrOnCaps)) then
begin
FOnPasswordCapsLocked(Self);
end;
end
else
begin
if Assigned(FOnPasswordCapsLocked) and
((self.PasswordChar <> #0) or ( not FValuePasswordChrOnCaps)) then
begin
FOnPasswordCapsFreed(Self);
end;
end;
end;
procedure TNCREdit.SetOnPasswordCapsFreed(const aValue: TNotifyEvent);
begin
FOnPasswordCapsFreed := aValue;
FBlockCapsBalloonTip := True;
end;
procedure TNCREdit.SetOnPasswordCapsLocked(const aValue: TNotifyEvent);
begin
FOnPasswordCapsLocked := aValue;
FBlockCapsBalloonTip := True;
end;
procedure TNCREdit.WndProc(var Message: TMessage);
begin
if (Message.Msg = EM_SHOWBALLOONTIP) and FBlockCapsBalloonTip then Exit;
inherited;
end;
end.
Mr Kobik made a very elegant piece of code that I think PasteBin should not be trusted to host, so I decided to add it here.
From what I understood it lets you handle TPasswordCapsLockState in one event handler that is fired when the TPasswordEdit receives focus, loses focus, CapsLock key pressed while on focus and an optional firing when PasswordChar is changed.
Using this approach I could use the OnPasswordCapsLock event to show/hide the image in my question instead of forcing the consumer of the component to use two event handlers for each state (very clever by the way and less error prone).
also as long as LNeedHandle := FBlockCapsBalloonTip and IsPassword; is True I have another added feature to TPasswordEdit which is the handling of OnEnter and OnExit in OnPasswordCapsLock as well,
So what can I say Mr Kobik Je vous tire mon chapeau.
type
TPasswordCapsLockState = (pcsEnter, pcsExit, pcsKey, pcsSetPasswordChar);
TPasswordCapsLockEvent = procedure(Sender: TObject;
Locked: Boolean; State: TPasswordCapsLockState) of object;
TPasswordEdit = class(TCustomEdit)
private
FIsCapsLocked: boolean;
FBlockCapsBalloonTip: boolean;
FOnPasswordCapsLock: TPasswordCapsLockEvent;
protected
procedure WndProc(var Message: TMessage); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure DoEnter; override;
procedure DoExit; override;
procedure HandlePasswordCapsLock(State: TPasswordCapsLockState); virtual;
function GetIsPassword: Boolean; virtual;
public
property IsPassword: Boolean read GetIsPassword;
published
property BlockCapsBalloonTip: boolean read FBlockCapsBalloonTip write FBlockCapsBalloonTip default False;
//... The usual property declaration of TEdit
property OnPasswordCapsLock: TPasswordCapsLockEvent read FOnPasswordCapsLock write FOnPasswordCapsLock;
end;
implementation
function TPasswordEdit.GetIsPassword: Boolean;
begin
Result := ((PasswordChar <> #0) or
// Edit control can have ES_PASSWORD style with PasswordChar == #0
// if it was creaed with ES_PASSWORD style
(HandleAllocated and (GetWindowLong(Handle, GWL_STYLE) and ES_PASSWORD <> 0)));
end;
procedure TPasswordEdit.HandlePasswordCapsLock;
var
LNeedHandle: Boolean;
begin
LNeedHandle := FBlockCapsBalloonTip and IsPassword;
if LNeedHandle then
begin
FIsCapsLocked := Odd(GetKeyState(VK_CAPITAL));
if Assigned(FOnPasswordCapsLock) then
FOnPasswordCapsLock(Self, FIsCapsLocked, State);
end;
end;
procedure TPasswordEdit.DoEnter;
begin
inherited;
HandlePasswordCapsLock(pcsEnter);
end;
procedure TPasswordEdit.DoExit;
begin
inherited;
HandlePasswordCapsLock(pcsExit);
end;
procedure TPasswordEdit.KeyUp(var Key: Word; Shift: TShiftState);
begin
inherited;
if Key = VK_CAPITAL then
HandlePasswordCapsLock(pcsKey);
end;
procedure TPasswordEdit.WndProc(var Message: TMessage);
begin
if (Message.Msg = EM_SHOWBALLOONTIP) and FBlockCapsBalloonTip and IsPassword then
Exit;
// Optional - if password char was changed
if (Message.Msg = EM_SETPASSWORDCHAR) and Self.Focused then
HandlePasswordCapsLock(pcsSetPasswordChar);
inherited;
end;

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.

How to make my TCustomControl descendant component stop flickering?

I have a graphical TCustomControl descendant component with a TScrollBar on it. The problem is that when I press the arrow key to move the cursor the whole canvas is painted in background color, including the region of the scroll bar, then the scroll bar is repainted and that makes scroll bar flicker. How can I solve this ?
Here is the code. There is no need install the component or to put something on the main form, just copy the code and assign TForm1.FormCreate event:
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, SuperList;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
List: TSuperList;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
List:=TSuperList.Create(self);
List.Top:=50; List.Left:=50;
List.Visible:=true;
List.Parent:=Form1;
end;
end.
SuperList.pas
unit SuperList;
interface
uses Windows, Controls, Graphics, Classes, Messages, SysUtils, StdCtrls, Forms;
type
TSuperList = class(TCustomControl)
public
DX,DY: integer;
ScrollBar: TScrollBar;
procedure Paint; override;
constructor Create(AOwner: TComponent); override;
procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
published
property OnMouseMove;
property OnKeyPress;
property OnKeyDown;
property Color default clWindow;
property TabStop default true;
property Align;
property DoubleBuffered default true;
property BevelEdges;
property BevelInner;
property BevelKind default bkFlat;
property BevelOuter;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Marus', [TSuperList]);
end;
procedure TSuperList.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
Message.Result:= Message.Result or DLGC_WANTARROWS;
end;
procedure TSuperList.WMKeyDown(var Message: TWMKeyDown);
begin
if Message.CharCode=VK_LEFT then begin dec(DX,3); Invalidate; exit; end;
if Message.CharCode=VK_RIGHT then begin inc(DX,3); Invalidate; exit; end;
if Message.CharCode=VK_UP then begin dec(DY,3); Invalidate; exit; end;
if Message.CharCode=VK_DOWN then begin inc(DY,3); Invalidate; exit; end;
inherited;
end;
procedure TSuperList.WMLButtonDown(var Message: TWMLButtonDown);
begin
DX:=Message.XPos;
DY:=Message.YPos;
SetFocus;
Invalidate;
inherited;
end;
constructor TSuperList.Create(AOwner: TComponent);
begin
inherited;
DoubleBuffered:=true;
TabStop:=true;
Color:=clNone; Color:=clWindow;
BevelKind:=bkFlat;
Width:=200;
Height:=100;
DX:=5; DY:=50;
ScrollBar:=TScrollBar.Create(self);
ScrollBar.Kind:=sbVertical;
ScrollBar.TabStop:=false;
ScrollBar.Align:=alRight;
ScrollBar.Visible:=true;
ScrollBar.Parent:=self;
end;
procedure TSuperList.Paint;
begin
Canvas.Brush.Color:=Color;
Canvas.FillRect(Canvas.ClipRect);
Canvas.TextOut(10,10,'Press arrow keys !');
Canvas.Brush.Color:=clRed;
Canvas.Pen.Color:=clBlue;
Canvas.Rectangle(DX,DY,DX+30,DY+20);
end;
end.
I think the first thing that I would do is remove that scroll bar control. Windows come with ready made scroll bars. You just need to enable them.
So, start by removing ScrollBar from the component. Then add a CreateParams override:
procedure CreateParams(var Params: TCreateParams); override;
Implement it like this:
procedure TSuperList.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := Params.Style or WS_VSCROLL;
end;
Yippee, your control now has a scroll bar.
Next you need to add a handler for WM_VSCROLL:
procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
And that's implemented like this:
procedure TSuperList.WMVScroll(var Message: TWMVScroll);
begin
case Message.ScrollCode of
SB_LINEUP:
begin
dec(DY, 3);
Invalidate;
end;
SB_LINEDOWN:
begin
inc(DY, 3);
Invalidate;
end;
...
end;
end;
You'll need to fill out the rest of the scroll codes.
I would also suggest that you do not set DoubleBuffered in the constructor of your component. Let the user set that if they wish. There's no reason for your control to require double buffering.

Adding Canvas to TScrollBox

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.

Resources