Drawing on a TEdit Component

The Unofficial Newsletter of Delphi Users - by Robert Vivrette

Drawing on a TEdit Component

by Angus Johnson - ajohnson@rpi.net.au

I started this component - as an exercise - to create my own DatePicker component (still using Delphi 2.01) based on the TDateEdit component first published in UNDU way back in 1995! TButtonEdit just draws a button on the TEdit surface. Clicking the button initiates an OnClick event. All you have to do is write the OnClick method!

I initially wrote the WM_PAINT method using API functions - to avoid some of the issues of using TCanvas but Robert Vivrette (what a kind fellow) thought the code may be simpler using a TCanvas object to draw the button. Well, I've rewritten WM_PAINT but left the old API code (commented out) at the end so you can decide. Why do things the easy way when you've already done it the hard way?

Editors Note: Both techniques are fine, however, we need to remember that Delphi does a lot of caching of Pens, Brushes, etc to optimize the performance of things like this. As a result, I suspect that the Delphi implementation might be a little faster as well as being easier to code and maintain.

Created on 5 March 1998, modified 18 March 1998.

unit ButtonEdit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TButtonEdit = class(TEdit)
private
    //FCanvas: TCanvas; //commented out - see below!
    //do you want to 'click' when the up or down arrow key pressed as well?
    FClickOnArrow: boolean;
    //do you want to 'click' when the Return key pressed as well?
    FClickOnReturn: boolean;
    //flag - is the button pressed or not
    FPressed: boolean;
    procedure Click; override;
    procedure CreateWnd; override;
    procedure WMPAINT(var Message: TMessage); message WM_PAINT;
    procedure WMLBUTTONDOWN(var Message: TWMMouse); message WM_LBUTTONDOWN;
    procedure WMLBUTTONUP(var Message: TWMMouse); message WM_LBUTTONUP;
    procedure WMMOUSEMOVE(var Message: TWMMouse); message WM_MOUSEMOVE;
    //procedure WMSETFOCUS(var Message: TMessage); message WM_SETFOCUS;
protected
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
public
    constructor Create(AOwner: TComponent); override;
published
    property ClickOnArrow: boolean read FClickOnArrow write FClickOnArrow;
    property ClickOnReturn: boolean read FClickOnReturn write FClickOnReturn;
end;

procedure Register;

implementation

const
BUTTONWIDTH = 17;

{----------------------------------------------------------------------}
{----------------------------------------------------------------------}

procedure Register;
begin
RegisterComponents('Samples', [TButtonEdit]);
end;
{----------------------------------------------------------------------}

constructor TButtonEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FPressed := false;
FClickOnArrow := true;
FClickOnReturn := false;
end;
{----------------------------------------------------------------------}

procedure TButtonEdit.CreateWnd;
begin
inherited CreateWnd;
//this is crucial to stop text disappearing under the button...
perform(EM_SETMARGINS,EC_RIGHTMARGIN,(BUTTONWIDTH+2) shl 16);
end;
{----------------------------------------------------------------------}

procedure TButtonEdit.WMLBUTTONDOWN(var Message: TWMMouse);
begin
inherited;
//draw button in pressed state...
if message.xpos >= clientwidth-BUTTONWIDTH+1 then begin
FPressed := true;
Refresh;
end;
end;
{----------------------------------------------------------------------}

procedure TButtonEdit.WMLBUTTONUP(var Message: TWMMouse);
begin
inherited;
//draw button in non-pressed state...
if FPressed then begin
FPressed := false;
Refresh;
end;
end;
{----------------------------------------------------------------------}

procedure TButtonEdit.WMMOUSEMOVE(var Message: TWMMouse);
begin
inherited;
//change cursor when over the button to an arrow (not the default I-beam)...
if message.xpos >= clientwidth-BUTTONWIDTH+1 then cursor := crArrow
else cursor := crDefault;
end;
{----------------------------------------------------------------------}

procedure TButtonEdit.Click;
var
pt: TPoint;
begin
//fix a minor cosmetic problem...
if FPressed then begin
    FPressed := false;
    Repaint;
end;
//Only process an OnClick method if the button is clicked,
//NOT if the text is clicked!
GetCursorPos(pt);
if PtInRect(Rect(clientwidth-BUTTONWIDTH+1,0,clientwidth,clientheight),
    ScreenToClient(pt)) then inherited Click;
end;
{----------------------------------------------------------------------}

procedure TButtonEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
//respond to up or down arrow keys or Return key with OnClick event if
//"ClickOnArrow" or "ClickOnReturn" property set...
inherited KeyDown(Key, Shift);
if ((Key = vk_Down) or (Key = vk_Up))
      and (Shift = []) and FClickOnArrow then begin
    Key := 0;
    inherited Click;
    end
else if (Key = vk_return) and FClickOnReturn then begin
    Key := 0;
    inherited Click;
end;
end;
{----------------------------------------------------------------------}

//This no longer seems to be necessary ... I've left it here just in case!
{procedure TButtonEdit.WMSETFOCUS(var Message: TMessage);
begin
inherited;
repaint;
end;}
{----------------------------------------------------------------------}

procedure TButtonEdit.WMPAINT(var Message: TMessage);
var
dc: HDC;
CntrPt: TPoint;
pic: array [0..3] of TPoint; //arrow 'picture' points
begin
// let windows draw the text!
// I don't really want to struggle with all the scrolling issues etc!
inherited;

//NOW DRAW THE BUTTON ... (not as bad as it looks if you take out the comments!)

//find the centre of the button...
CntrPt := point(clientwidth - BUTTONWIDTH div 2, clientheight div 2);
//offset CntrPt by 1 if pressed...
if FPressed then CntrPt := point(CntrPt.x+1,CntrPt.y+1);
//get button arrow drawing coordinates from CntrPt...
pic[0] := point( CntrPt.x-5,CntrPt.y);
pic[1] := point( CntrPt.x,CntrPt.y-5);
pic[2] := point( CntrPt.x+5, CntrPt.y);
pic[3] := point( CntrPt.x, CntrPt.y+5);

//Notes:
//1. As I'm calling the inherited WMPAINT method before drawing the button -
// I have to use getDC(handle) instead of beginpaint(handle,paintstruct)
// otherwise I don't see the button! (I think due to clipping.)
//2. If I wanted to draw the text as well as the button (without calling
// the inherited method) then I would have to use beginpaint(handle,paintstruct).
dc := getDC(handle);

//To make this method a little more efficient you could add a private Canvas field
// to the component and create it once only in TButtonEdit.create and free it in
//TButtonEdit.destroy. I've kept it all here for simplicity.
//(Don't use TControlCanvas instead of TCanvas in TButtonEdit.create -
//It doesn't work! - Someone might explain TControlCanvas to me.)
with TCanvas.create do begin
    Handle := dc;
    Brush.Color := clBtnFace;
    //Brush.style := bsSolid;

    //paint the button surface...
    FillRect(rect(clientwidth-BUTTONWIDTH+1,0,clientwidth,clientheight));
    //draw the button edges...
    if FPressed then Pen.color := clBtnShadow else Pen.color := clBtnHighlight;
    Moveto(clientwidth-BUTTONWIDTH+2,clientheight-1);
    Lineto(clientwidth-BUTTONWIDTH+2,1);
    Lineto(clientwidth-1,1);
    if FPressed then Pen.color := clBtnHighlight else Pen.color := clBtnShadow;
    Lineto(clientwidth-1,clientheight-1);
    Lineto(clientwidth-BUTTONWIDTH+2,clientheight-1);
    //draw the arrows...
    Brush.Color := clGreen;
    Pen.color := clBlack;
    polygon(pic);
    Pen.color := clBtnFace;
    Moveto(CntrPt.x-5,CntrPt.y);
    Lineto(CntrPt.x+6,CntrPt.y);
    Handle := 0;
    free; //the canvas.
end;
ReleaseDC(handle,dc);
end;
{----------------------------------------------------------------------}

(*
//Old WMPAINT Method (not using TCanvas)...

procedure TButtonEdit.WMPAINT(var Message: TMessage);
var
dc: HDC;
SilverBrush, ArrowBrush, Oldbrush: HBrush;
WhitePen, GrayPen, SilverPen, OldPen: HPen;
CntrPt: TPoint;
pic: array [0..3] of TPoint; // for arrow 'picture'.
begin
inherited;

//NOW DRAW BUTTON ...

//find the centre of the button...
CntrPt := point(clientwidth - BUTTONWIDTH div 2, clientheight div 2);
//offset by 1 if pressed...
if FPressed then CntrPt := point(CntrPt.x+1,CntrPt.y+1);
//get button arrow coordinates...
pic[0] := point( CntrPt.x-5,CntrPt.y);
pic[1] := point( CntrPt.x,CntrPt.y-5);
pic[2] := point( CntrPt.x+5, CntrPt.y);
pic[3] := point( CntrPt.x, CntrPt.y+5);

//create handles ...
dc := getDC(handle);
SilverBrush := CreateSolidBrush(GetSysColor(COLOR_BTNFACE));
ArrowBrush := CreateSolidBrush(clGreen);
WhitePen := CreatePen(PS_SOLID,1,clWhite);
GrayPen := CreatePen(PS_SOLID,1,clGray);
SilverPen := CreatePen(PS_SOLID,1,GetSysColor(COLOR_BTNFACE));

//draw button surface and outline...
OldBrush := SelectObject(dc, ArrowBrush);
FillRect(dc,rect(clientwidth-BUTTONWIDTH+1,0,clientwidth,clientheight),SilverBrush);

if FPressed then OldPen := SelectObject(dc,GrayPen)
else OldPen := SelectObject(dc,WhitePen);
MovetoEx(dc,clientwidth-BUTTONWIDTH+2,clientheight-1,nil);
Lineto(dc,clientwidth-BUTTONWIDTH+2,1);
Lineto(dc,clientwidth-1,1);
if FPressed then SelectObject(dc,WhitePen)
else SelectObject(dc,GrayPen);
Lineto(dc,clientwidth-1,clientheight-1);
Lineto(dc,clientwidth-BUTTONWIDTH+2,clientheight-1);

//draw up&down arrows...
SelectObject(dc,OldPen);
polygon(dc,pic,4);
SelectObject(dc,SilverPen);
MovetoEx(dc,CntrPt.x-5,CntrPt.y,nil);
Lineto(dc,CntrPt.x+6,CntrPt.y);

//clean up ...
SelectObject(dc,OldPen);
SelectObject(dc, OldBrush);

DeleteObject(WhitePen);
DeleteObject(SilverPen);
DeleteObject(GrayPen);
DeleteObject(SilverBrush);
DeleteObject(ArrowBrush);
ReleaseDC(handle,dc);
end;
*)
{----------------------------------------------------------------------}

end.