I am trying to change the background color of a DateTimePicker, but my question is unrelated to what i'm trying to do.
I am catching a window's WM_PAINT
message, letting the default drawing implementation happen (i.e. the one inside ComCtrl.dll), and then coming along after that and scribbling over top of it.
Initially my code is simple:
TDateTimePicker = class(Vcl.ComCtrls.TDateTimePicker)
protected
procedure WMPaint(var Message: TMessage); message WM_PAINT;
end;
procedure TDateTimePicker.WMPaint(var Message: TMessage);
begin
inherited;
end;
I do nothing, and the control paints normally:
Now the fun begins
Now i will perform some actual drawing. It's not the drawing i want, but it demonstrates that it works. I will draw a criss-cross on the control's rect:
procedure TDateTimePicker.WMPaint(var Message: TMessage);
var
dc: HDC;
rc: TRect;
p: HPEN;
begin
inherited;
//Get the device context to scribble on
dc := GetDC(Self.Handle);
if dc = 0 then
Exit;
try
rc := Self.GetClientRect;
//Create a pen to draw a criss-cross
p := CreatePen(PS_SOLID, 0, ColorToRGB(clLime));
p := SelectObject(dc, p); //select the pen into the dc
Winapi.Windows.MoveToEx(dc, rc.Left, rc.Top, nil);
Winapi.Windows.LineTo(dc, rc.Right, rc.Bottom);
Winapi.Windows.MoveToEx(dc, rc.Right, rc.Top, nil);
Winapi.Windows.LineTo(dc, rc.Left, rc.Bottom);
P := SelectObject(dc, p); //restore old pen
DeleteObject(p); //delete our pen
finally
ReleaseDC(Self.Handle, dc);
end;
end;
It's pretty simple stuff:
- get the
HDC
that we will draw on - get the client rect of the control
- create a solid red pen
- select the pen into the DC
- draw the criss-cross
- restore the old pen
- delete our pen
And it works!
Of course it works.
Now to fill the entire rect
I don't want to draw a criss-cross, i want to fill the background. First i will demonstrate a way to accomplish my goal using a horrible, horrible method:
I will stroke the width of the control with a very thick pen
It is a horrible thing to do, but it has the virtue of actually working:
procedure TDateTimePicker.WMPaint(var Message: TMessage);
var
dc: HDC;
rc: TRect;
p: HPEN;
begin
inherited;
dc := GetDC(Self.Handle);
if dc = 0 then
Exit;
try
rc := Self.GetClientRect;
//Fill a rectangle using a pen (cause FillRect doesn't work)
p := CreatePen(PS_SOLID, rc.Height, ColorToRGB(clRed));
p := SelectObject(dc, p);
Winapi.Windows.MoveToEx(dc, rc.Left, (rc.Bottom+rc.Top) div 2, nil); //middle of left edge
Winapi.Windows.LineTo(dc, rc.Right, (rc.Bottom+rc.Top) div 2); //middle of right edge
P := SelectObject(dc, p); //restore old pen
DeleteObject(p); //delete our pen
//Create a pen to draw a criss-cross
p := CreatePen(PS_SOLID, 0, ColorToRGB(clLime));
p := SelectObject(dc, p); //select the pen into the dc
Winapi.Windows.MoveToEx(dc, rc.Left, rc.Top, nil);
Winapi.Windows.LineTo(dc, rc.Right, rc.Bottom);
Winapi.Windows.MoveToEx(dc, rc.Right, rc.Top, nil);
Winapi.Windows.LineTo(dc, rc.Left, rc.Bottom);
P := SelectObject(dc, p); //restore old pen
DeleteObject(p); //delete our pen
finally
ReleaseDC(Self.Handle, dc);
end;
end;
It's pretty simple stuff:
- create a pen 23 pixels high
- stroke left-to-right the entire width of the picker
And it works:
Of course it works!
But i don't want to wipe out everything
I don't want to erase everything in the datetimepicker, just the "client" area. So i adjust the rect:
- subtract 2 pixels off the top, left, and bottom
- subtract 34 pixels off the right edge for the datetimepicker drop-down button
with code snippet:
rc := Self.GetClientRect;
//rc := GetRectOfThePartIWant;
rc.Left := 2;
rc.Top := 2;
rc.Bottom := rc.Bottom-2;
rc.Right := rc.Right-34; //button width is 34 (use DateTime_GetDateTimePickerInfo.rcButton)
//Fill a rectangle using a pen (cause FillRect doesn't work)
//p := CreatePen(PS_SOLID, rc.Height, ColorToRGB(clRed));
br := Default(TLogBrush);
br.lbStyle := BS_SOLID;
br.lbColor := ColorToRGB($00CCCCFF);
br.lbHatch := 0; //ignored for a BS_SOLID brush
p := ExtCreatePen(PS_SOLID or PS_GEOMETRIC or PS_ENDCAP_FLAT, rc.Height, br, 0, nil);
if p <> 0 then
begin
p := SelectObject(dc, p);
Winapi.Windows.MoveToEx(dc, rc.Left, (rc.Bottom+rc.Top) div 2, nil); //middle of left edge
Winapi.Windows.LineTo(dc, rc.Right, (rc.Bottom+rc.Top) div 2); //middle of right edge
P := SelectObject(dc, p); //restore old pen
DeleteObject(p); //delete our pen
end;
And it works:
Of course it works!
What's wrong with FillRect?
Originally i simply used FillRect
, except it insists only on drawing in white; rather than any color:
procedure TDateTimePicker.WMPaint(var Message: TMessage);
var
dc: HDC;
rc: TRect;
br: TLogBrush;
b: HBRUSH;
le: Integer;
p: HPEN;
begin
inherited;
dc := GetDC(Self.Handle);
if dc = 0 then
Exit;
try
rc := Self.GetClientRect;
b := CreateSolidBrush(ColorToRGB(clRed));
if b <> 0 then
begin
b := SelectObject(dc, b); //select the brush into the DC
if b <> 0 then
begin
le := FillRect(dc, rc, b);
if le = 0 then
begin
//Draw failed
if IsDebuggerPresent then
DebugBreak;
end;
SelectObject(dc, b); //restore the old brush
end;
DeleteObject(b);
end;
//Create a pen to draw a criss-cross
p := CreatePen(PS_SOLID, 0, ColorToRGB(clLime));
p := SelectObject(dc, p); //select the pen into the dc
Winapi.Windows.MoveToEx(dc, rc.Left, rc.Top, nil);
Winapi.Windows.LineTo(dc, rc.Right, rc.Bottom);
Winapi.Windows.MoveToEx(dc, rc.Right, rc.Top, nil);
Winapi.Windows.LineTo(dc, rc.Left, rc.Bottom);
P := SelectObject(dc, p); //restore old pen
DeleteObject(p); //delete our pen
finally
ReleaseDC(Self.Handle, dc);
end;
end;
and it doesn't work:
of course it doesn't work. It's trying to make my life difficult. If it worked then i wouldn't have gotten to spend 9 hours on it.
I tried only filling the top-half of the rectangle; to make sure my origin was correct:
rc := Self.GetClientRect;
rc2 := rc;
rc2.Bottom := (rc2.Top + rc2.Bottom) div 2;
b := CreateSolidBrush(ColorToRGB(clRed));
if b <> 0 then
begin
b := SelectObject(dc, b); //select the brush into the DC
if b <> 0 then
begin
le := FillRect(dc, rc2, b);
if le = 0 then
begin
//Draw failed
if IsDebuggerPresent then
DebugBreak;
end;
SelectObject(dc, b); //restore the old brush
end;
DeleteObject(b);
end;
//Create a pen to draw a criss-cross
p := CreatePen(PS_SOLID, 0, ColorToRGB(clLime));
p := SelectObject(dc, p); //select the pen into the dc
Winapi.Windows.MoveToEx(dc, rc.Left, rc.Top, nil);
Winapi.Windows.LineTo(dc, rc.Right, rc.Bottom);
Winapi.Windows.MoveToEx(dc, rc.Right, rc.Top, nil);
Winapi.Windows.LineTo(dc, rc.Left, rc.Bottom);
P := SelectObject(dc, p); //restore old pen
DeleteObject(p); //delete our pen
and it doesn't work:
Of course it doesn't work.
Why doesn't it work?
Why doesn't it work?
Bonus Chatter
You cannot use the Delphi Styles Engine, because the Styles Engine is not enabled when using Windows themes (only when using custom theme).
WM_ERASEBKGND
to do the erasing of the background. Unfortunately the client paint overwrites the entire background. So my only choice was the do the scribbling after the default paint. – Croft