moveshapebutton.pas

本人原创（delphi程序设计提高与应用）源码。《可移动的形状按钮》其目的是教学生如何制作自定义组件。本控件可制作矩形或椭圆形按钮

unit MoveShapeButton;

interface

uses
  SysUtils, Classes, Controls,Graphics,Messages; //Graphics   //Messages

type
  TshapeType=(Ellipse,Rectangle);

  TMoveShapeButton = class(TGraphicControl)
  private
    { Private declarations }
    Ftext:string;
    Fbkcolor:Tcolor;
    Fshape:Tshapetype;
    PressDown:boolean;  //按钮的按下状态
    Fleftmouseup:TMouseEvent;
    Fleftmousedown:TMouseEvent;
    FOnMouseMove: TMouseMoveEvent;

    procedure WMLbuttondown(var Msg:TWMLButtonDown);
              message WM_LBUTTONDOWN; //定义事件处理过程
    procedure WMLbuttonup(var Msg:TWMLButtonUp);
              message WM_LBUTTONUP;
    procedure WMMouseMove(var Msg: TWMMouseMove);
              message WM_MOUSEMOVE;
    
  protected
    { Protected declarations }
    procedure Settext(value:string);
    function Gettext:string;
    procedure Setbkcolor(value:tcolor);
    procedure Setshape(value:Tshapetype);
  public
    { Public declarations }
    procedure paint; override;
  published
    { Published declarations }
    property text:string read Gettext write Settext;
    property bkcolor:Tcolor read Fbkcolor write Setbkcolor;
    property shape:Tshapetype read Fshape write Setshape;
    property Font;
    Property OnClick;
    property OnLeftMouseDown:TMouseEvent read Fleftmousedown
                  write Fleftmousedown;  // 声明按下鼠标左键事件
    property OnLeftMouseUp:TMouseEvent read Fleftmouseup
                  write Fleftmouseup;   //  声明释放鼠标左键事件
    property OnMouseMove: TMouseMoveEvent read FOnMouseMove
                  write FOnMouseMove;   //  声明释放鼠标移动事件
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('NewComponent', [TMoveShapeButton]);
end;

procedure TMoveShapeButton.Settext(value:string);
begin
  Ftext:=value;
  Invalidate;
end;

procedure TMoveShapeButton.Setbkcolor(value:tcolor);
begin
  Fbkcolor:=value;
  Invalidate;
end;

{procedure TMoveShapeButton.Settextcolor(value:tcolor);
begin
  Ftextcolor:=value;
  Invalidate;
end;}

function TMoveShapeButton.Gettext:string;
begin
  result:=Ftext;
end;

procedure TMoveShapeButton.Setshape(value:Tshapetype);
begin
  Fshape:=value;
  Invalidate;
end;

procedure TMoveShapeButton.paint;
//Paint过程通过Tcanvas对象，根据对象监视器设置的属性绘制出按钮
Var
  Texthalf:integer;
  SWidth:integer;
begin
  canvas.Pen.Color :=Fbkcolor;   //按钮边框线的颜色
  canvas.brush.Color :=Fbkcolor; //按钮填充的颜色

  if Fshape=Ellipse then        //如果设置为椭圆
    canvas.Ellipse(0,0,width,height)  //调用绘制椭圆的方法
  else if Fshape=Rectangle then //如果设置为矩形
    canvas.Rectangle(0,0,width,height);  //调用绘制矩形的方法

  canvas.Font:=Font;  //按钮上文字的字体格式
  Texthalf:=length(text)* font.Size div 2; //计算按钮文字总宽度的一半
  SWidth:=Texthalf * 7 div 10; //按70％的比例去掉文字间隙
  canvas.TextOut(width div 2 - SWidth,height div 2 - font.Size div 2,text);
  //绘制按钮上的文字
end;

procedure TMoveShapeButton.WMLbuttondown(var msg:Twmlbuttondown);
begin
  if Assigned(Fleftmousedown) then //如果句柄不为空，即使用该组件的程序员编写了事件处理代码
    Fleftmousedown(self,mbleft,[],msg.xpos,msg.ypos); //执行事件句柄
  cursor:= crhandpoint; //设置按钮的鼠标图形为工作状态
  left:=left+Msg.XPos-(width div 2);
  top:=top+Msg.ypos-(Height div 2);
  //将按钮移动使鼠标当前位置为按钮的中心
  PressDown:=true; //设置按钮的按下状态为True
end;

procedure TMoveShapeButton.WMMouseMove(var Msg: TWMMouseMove);
begin
  if Assigned(FOnMouseMove) then //如果句柄不为空，即用该组件的程序员编写了事件处理代码
    FOnMouseMove(self,[ssLeft],Msg.xpos,Msg.ypos);  //执行事件句柄

  if PressDown then   //如果按钮处于按下状态
  begin //将按钮随鼠标移动
    left:=left+Msg.xpos-(width div 2);
    top:=top+Msg.ypos-(Height div 2);
  end;
end;

procedure TMoveShapeButton.WMLbuttonup(var msg:Twmlbuttonup);
begin
  if Assigned(Fleftmouseup) then  //如果句柄不为空，即用该组件的程序员编写了事件处理代码
    Fleftmouseup(self,mbleft,[],msg.xpos,msg.ypos); //执行事件句柄
   PressDown:=False;  //设置按钮的按下状态为Faulse
   cursor:= crDefault;//设置按钮的鼠标图形为默认状态
end;

end.