lxactivebtn.pas

这个程序软件很不错很不错的

unit lxactivebtn;

interface

uses
  SysUtils, Classes, Controls,Messages, Windows,
  consts, Forms, Menus, Graphics, Stdctrls,Dialogs;

type
  TactiveChange = procedure(sender:Tobject;active:Boolean) of object;

type
  Tlxactivebtn = class(TGraphicControl)
  private
    Fabout:string;
    Factive:boolean;
    Fpicture:Tpicture;
    Fonprogress:TprogressEvent;
    Fstretch:boolean;
    Fcenter:Boolean;
    FincrementalDisplay:boolean;
    Ftransparent:boolean;
    Fdrawing:Boolean;
    Fproportional:boolean;
    Fonactivechange:TActivechange;

    Function Getcanvas:Tcanvas;
    procedure picturechanged(sender:Tobject);
    procedure setcenter(Value:boolean);
    procedure setpicture(Value:Tpicture);
    procedure setstretch(Value:boolean);
    procedure setTransparent(Value:boolean);
    procedure setproportional(Value:boolean);

    { Private declarations }
  protected
    function canautosize(var Newwidth,Newheight:integer):boolean;override;
    function DestRect:Trect;
    function dopalettechange:boolean;
    function Getpalette:HPALETTE;override;
    procedure paint;override;
    procedure progress(Sender:Tobject;Stage:TprogressStage;
      percentDone:Byte;RedrawNow:boolean;const R:Trect;const Msg:String);
      dynamic;
    procedure CMMouseenter(var Message:Tmessage);Message CM_MOUSEENTER;
    procedure CMMouseleave(var Message:Tmessage);MEssage CM_MOUSELEAVE;

    { Protected declarations }
  public
    constructor create(Aowner:Tcomponent);override;
    destructor Destroy;override;
    property Canvas:Tcanvas read GetCanvas;

    { Public declarations }
  published
    property about:string read Fabout write Fabout;
    property Anchors;
    property Autosize;
    property center:boolean read Fcenter write setcenter default false;
    property constraints;
    property dragcursor;
    property dragkind;
    property dragmode;
    property enabled;
    property incrementaldisplay:boolean read FincrementalDisplay write
      FincrementalDisplay default false;
    property parentShowHint;
    property picture:Tpicture read Fpicture write setpicture;
    property popupmenu;
    property proportional:boolean read Fproportional write setproportional
      default false;
    property showhint;
    property stretch:boolean read Fstretch write Setstretch default False;
    property visible;
    property onactivechange:Tactivechange read Fonactivechange write
      Fonactivechange;
    property onclick;
    property oncontextpopup;
    property onDblclick;
    property onDragDrop;
    property onDragover;
    property onEndDock;
    property onendDrag;
    property onMouseDown;
    property onMouseMove;
    property onMouseup;
    property onProgress:TprogressEvent read Fonprogress write Fonprogress;
    property onStartDock;
    property onStartDrag;

    { Published declarations }
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('liuxiangvcl', [Tlxactivebtn]);
end;

{ Tlxactivebtn }

function Tlxactivebtn.canautosize(var Newwidth,
  Newheight: integer): boolean;
begin
Result:=True;
if not (csDesigning in componentstate) or (picture.Width > 0) and
  (picture.Height > 0) then
  begin
    if align in [alnone,alleft,alright] then
      newwidth:=picture.Width;
    if align in [alnone,altop,albottom] then
      newheight:=picture.Height;
  end;
end;

procedure Tlxactivebtn.CMMouseenter(var Message: Tmessage);
begin
  Factive:=True;
  if not (csDesigning in componentstate) then
    repaint;
  if assigned(Fonactivechange) then
    fonactivechange(self,true);
end;

procedure Tlxactivebtn.CMMouseleave(var Message: Tmessage);
begin
  Factive:=False;
  if not (csDesigning in componentState) then
    repaint;
  if assigned(Fonactivechange) then
    fonactivechange(self,true);
end;

constructor Tlxactivebtn.create(Aowner: Tcomponent);
begin
  inherited Create(Aowner);
  controlStyle:=controlStyle+[csReplicatable];
  Factive:=False;
  Fpicture:=Tpicture.Create;
  Fpicture.OnChange:=pictureChanged;
  Fpicture.OnProgress:=progress;
  Height:=105;
  Width:=105;
  Ftransparent:=True;
  cursor:=crHandPoint;
end;

function Tlxactivebtn.DestRect: Trect;
var
  w,h,cw,ch:integer;
  xyaspect:double;
begin
  w:=picture.Width;
  h:=picture.Height;
  cw:=clientWidth;
  ch:=clientHeight;
  if Stretch or (proportional and ((w>cw) or (h>ch))) then
    begin
      if proportional and (w>0) and (h>0) then
        begin
          xyaspect:=w/h;
          if w>h then
            begin
              w:=cw;
              h:=Trunc(cw/xyaspect);
              if h>ch then
                begin
                  h:=ch;
                  w:=Trunc(ch*xyaspect);
                end;
            end
            else
            begin
              h:=ch;
              w:=Trunc(ch*xyaspect);
              if w>cw then
                begin
                  w:=cw;
                  h:=trunc(cw/xyaspect);
                end;
            end;
        end
        else
        begin
          w:=cw;
          h:=ch;
        end;
    end;

    with Result do
      begin
        Left:=0;
        top:=0;
        Right:=w;
        bottom:=h;
      end;

    if center then
      offsetRect(Result,(cw-w) div 2,(ch-h) div 2);
    if Factive and (not (csDesigning in ComponentState)) then
      begin
        dec(Result.Left,2);
        dec(Result.Right,2);
        dec(Result.Top,2);
        dec(Result.Bottom,2);
      end;
end;

destructor Tlxactivebtn.Destroy;
begin
  Fpicture.Free;
  inherited Destroy;
end;

function Tlxactivebtn.dopalettechange: boolean;
var
  ParentForm:TcustomForm;
  Tmp:Tgraphic;
begin
  Result:=False;
  Tmp:=picture.Graphic;
  if Visible and (not (csLoading in componentState)) and (Tmp<>nil) and
    (tmp.PaletteModified) then
      begin
        if (tmp.Palette=0) then
          tmp.PaletteModified:=False
          else
          begin
            parentForm:=GetparentForm(Self);
            if Assigned(parentForm) and parentForm.Active and
              parentform.HandleAllocated then
                begin
                  if FDrawing then
                    parentform.Perform(WM_QueryNewPalette,0,0)
                    else
                    postMessage(parentform.Handle,WM_queryNewPalette,0,0);
                    Result:=True;
                    tmp.paletteModified:=False;  
                end;
          end;
      end;
end;

function Tlxactivebtn.Getcanvas: Tcanvas;
var
  bitMap:Tbitmap;
begin
  if picture.Graphic = nil then
    begin
      bitmap:=Tbitmap.Create;
      try
        bitmap.Width:= width;
        bitmap.Height:=height;
        picture.Graphic:=bitmap;
      finally
        bitmap.Free;
      end;
    end;
    if picture.Graphic is Tbitmap then
      Result:=tbitmap(picture.Graphic).Canvas
      else
      Raise Einvalidoperation.Create(SimageCanvasNeedsBitmap);
end;

function Tlxactivebtn.Getpalette: HPALETTE;
begin
  Result:=0;
  if Fpicture.Graphic <> nil then
    Result:=Fpicture.Graphic.Palette;
end;

procedure Tlxactivebtn.paint;
var
  save:boolean;
  FactiveGraphic:Tgraphic;
begin
  if CSdesigning in componentState then
    with inherited canvas do
      begin
        pen.Style:=psDot;
        brush.Style:=bsClear;
        rectangle(0,0,Width,Height);
      end;
      Save:=Fdrawing;
      Fdrawing:=True;
      try
        with inherited canvas do
          begin
            StretchDraw(DestRect,picture.Graphic);
          end;
      finally
        Fdrawing:=Save;
      end;
end;

procedure Tlxactivebtn.picturechanged(sender: Tobject);
var
  G:Tgraphic;
  D:Trect;
begin
  if Autosize and (picture.Width > 0) and (picture.Height > 0) then
    setbounds(left,top,picture.Width,picture.Height);
  G:=picture.Graphic;
  if G<>nil then
    begin
      if not ((G is Tmetafile) or (G is Ticon)) then
        g.Transparent:=Ftransparent;
      D:=DestRect;
      if (not G.Transparent) and (D.Left<=0) and (D.Top<=0) and
        (d.Right>=width) and (d.Bottom>=height) then
        controlstyle:=controlstyle+[csopaque]
        else
        controlstyle:=controlstyle-[csopaque];
      if dopalettechange and Fdrawing then
        update;
    end
    else
      controlstyle:=controlstyle-[csopaque];
    if not Fdrawing then
      invalidate;
end;

procedure Tlxactivebtn.progress(Sender: Tobject; Stage: TprogressStage;
  percentDone: Byte; RedrawNow: boolean; const R: Trect;
  const Msg: String);
begin
  if FincrementalDisplay and redrawnow then
    begin
      if dopalettechange then
        update
        else
        paint;
    end;
    if assigned(fonProgress) then
      fonprogress(sender,stage,percentdone,redrawnow,r,msg);
end;

procedure Tlxactivebtn.setcenter(Value: boolean);
begin
  if Fcenter<>Value then
    begin
      Fcenter:=Value;
      pictureChanged(self);
    end;
end;

procedure Tlxactivebtn.setpicture(Value: Tpicture);
begin
  Fpicture.Assign(Value);
end;

procedure Tlxactivebtn.setproportional(Value: boolean);
begin
  if Fproportional<>Value then
    begin
      Fproportional:=value;
      picturechanged(self);
    end;
end;

procedure Tlxactivebtn.setstretch(Value: boolean);
begin
  if Value<>Fstretch then
    begin
      Fstretch:=Value;
      picturechanged(self);
    end;
end;

procedure Tlxactivebtn.setTransparent(Value: boolean);
begin
  if Value<>Ftransparent then
    begin
      Ftransparent:=Value;
      picturechanged(self);
    end;
end;

end.