maskimagebutton.pas

机房管理系统 是用VB设计的简单的管理系统

{$A+,B-,D+,F-,G+,I+,K+,L+,N+,P+,Q-,R-,S+,T-,V-,W-,X+,Y+}
unit MaskImageButton;

{
*
** 根据图案自动生动边界的按纽
** 作者：未知
** 修改：午秋
** 更新：增加了一个Action 属性
*
}
interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Buttons;

CONST FBevelWidth = 1;
type
  TMaskImgBtn = class(TGraphicControl)
  private
    FAutoSize: Boolean;
    FBitmap: TBitmap;
    FBitmapUp: TBitmap;
    FBitmapDown: TBitmap;
    FHitTestMask: TBitmap;
    FPrevCursorSaved: Boolean;
    FPrevCursor: TCursor;
    FPrevShowHintSaved: Boolean;
    FPrevShowHint: Boolean;
    FPreciseShowHint: Boolean;
    procedure AdjustBounds;
    procedure AdjustSize(var W, H: Integer);
    function BevelColor(const AState: TButtonState; const TopLeft: Boolean): TColor;
    procedure BitmapChanged(Sender: TObject);
    procedure Create3DBitmap(Source: TBitmap; const AState: TButtonState; Target: TBitmap);
    procedure SetAutoSize(Value: Boolean);
    procedure SetBitmap(Value: TBitmap);
    procedure SetBitmapDown(Value: TBitmap);
    procedure SetBitmapUp(Value: TBitmap);
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
    procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  protected
    FState: TButtonState;
    procedure DefineProperties(Filer: TFiler); override;
    procedure DrawButtonText(Canvas: TCanvas; const Caption: String; TextBounds: TRect; State: TButtonState); virtual;
    function GetPalette: HPALETTE; override;
    procedure Loaded; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;  X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;  X, Y: Integer); override;
    procedure Paint; override;
    procedure ReadBitmapDownData(Stream: TStream); virtual;
    procedure ReadBitmapUpData(Stream: TStream); virtual;
    procedure WriteBitmapDownData(Stream: TStream); virtual;
    procedure WriteBitmapUpData(Stream: TStream); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    procedure Invalidate; override;
    function PtInMask(const X, Y: Integer): Boolean; virtual;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    property BitmapUp: TBitmap read FBitmapUp;
    property BitmapDown: TBitmap read FBitmapDown;
  published
    property Action;
    property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property Caption;
    property Enabled;
    property Font;
    property ParentFont;
    property ShowHint;
    property Visible;
    property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

type
  Apair = Array[0..1] of Integer;

function MakeMask(ColorBmp: TBitmap; TransparentColor: TColor): TBitmap;
var R: TRect;
    OldBkColor: TColorRef;
begin
  Result := TBitmap.Create;
  try
    Result.Monochrome := True;
    Result.Width := ColorBmp.Width;
    Result.Height := ColorBmp.Height;
    OldBkColor := SetBkColor(ColorBmp.Canvas.Handle, ColorToRGB(TransparentColor));
    R := Rect(0, 0, ColorBmp.Width, ColorBmp.Height);
    Result.Canvas.CopyMode := cmSrcCopy;
    Result.Canvas.CopyRect(R, ColorBmp.Canvas, R);
    SetBkColor(ColorBmp.Canvas.Handle, OldBkColor);
  except
    Result.Free;
    Raise;
  end;

end;

function MakeBorder(Source, NewSource: TBitmap; const OffsetPts: Array of Apair;
  TransparentColor: TColor): TBitmap;
var I, W, H: Integer;
    R, NewR: TRect;
    SmallMask, BigMask, NewSourceMask: TBitmap;
begin
  Result := TBitmap.Create;
  try
    W := Source.Width;
    H := Source.Height;
    R := Rect(0, 0, W, H);

    Result.Monochrome := True;
    Result.Width := W;
    Result.Height := H;

    SmallMask := MakeMask(Source, TransparentColor);
    NewSourceMask := MakeMask(NewSource, TransparentColor);
    BigMask := MakeMask(NewSourceMask, TransparentColor);

    try

      BigMask.Canvas.CopyMode := cmSrcCopy;
      BigMask.Canvas.CopyRect(R, NewSourceMask.Canvas, R);

      for I := Low(OffsetPts) to High(OffsetPts) do
      begin
        if (OffsetPts[I, 0] = 0) and (OffsetPts[I, 1] = 0) then
          Break;
        NewR := R;
        OffsetRect(NewR, OffsetPts[I, 0], OffsetPts[I, 1]);
        BigMask.Canvas.CopyMode := cmSrcAnd;
        BigMask.Canvas.CopyRect(NewR, SmallMask.Canvas, R);
      end;
      BigMask.Canvas.CopyMode := cmSrcCopy;

      with Result do
      begin
        Canvas.CopyMode := cmSrcCopy;
        Canvas.CopyRect(R, NewSourceMask.Canvas, R);
        Canvas.CopyMode := $00DD0228;
        Canvas.CopyRect(R, BigMask.Canvas, R);
        Canvas.CopyMode := cmSrcCopy;
      end;

    finally
      SmallMask.Free;
      NewSourceMask.Free;
      BigMask.Free;
    end;

  except
    Result.Free;
    Raise;
  end;

end;

{ TNoShape }
constructor TMaskImgBtn.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetBounds(0, 0, 80, 80);
  ControlStyle := [csCaptureMouse, csOpaque];
  FAutoSize := True;
  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChanged;
  FBitmapUp := TBitmap.Create;
  FBitmapDown := TBitmap.Create;
  FHitTestMask := nil;
  ParentFont := True;
  FState := bsUp;
  FPreciseShowHint := True;
{  Caption := ClassName;}
end;

destructor TMaskImgBtn.Destroy;
begin
  FBitmap.Free;
  FBitmapUp.Free;
  FBitmapDown.Free;
  FHitTestMask.Free;
  inherited Destroy;
end;

procedure TMaskImgBtn.Paint;
var W, H: Integer;
    Composite, Mask, Overlay, CurrentBmp: TBitmap;
    R, NewR: TRect;
begin
  if csDesigning in ComponentState then
    with Canvas do
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;

  if (csDesigning in ComponentState) or
    (FState in [bsDisabled, bsExclusive]) then
    FState := bsUp;

  if (FState = bsUp) then CurrentBmp := FBitmapUp
  else CurrentBmp := FBitmapDown;

  if not CurrentBmp.Empty then
  begin

    W := Width;
    H := Height;
    R := ClientRect;
    NewR := R;

    Composite := TBitmap.Create;
    Overlay := TBitmap.Create;

    try
      with Composite do
      begin
        Width := W;
        Height := H;
        Canvas.CopyMode := cmSrcCopy;
        Canvas.CopyRect(R, Self.Canvas, R);
      end;

      with Overlay do
      begin
        Width := W;
        Height := H;
        Canvas.CopyMode := cmSrcCopy;
        Canvas.Brush.Color := FBitmap.TransparentColor;
        Canvas.FillRect(R);
        if FState = bsDown then
          OffsetRect(NewR, 1, 1);
        Canvas.CopyRect(NewR, CurrentBmp.Canvas, R);
      end;

      Mask := MakeMask(Overlay, FBitmap.TransparentColor);
      try

        Composite.Canvas.CopyMode := cmSrcAnd;
        Composite.Canvas.CopyRect(R, Mask.Canvas, R);


        Overlay.Canvas.CopyMode := $00220326;
        Overlay.Canvas.CopyRect(R, Mask.Canvas, R);


        Composite.Canvas.CopyMode := cmSrcPaint;
        Composite.Canvas.CopyRect(R, Overlay.Canvas, R);

        Canvas.CopyMode := cmSrcCopy;
        Canvas.CopyRect(R, Composite.Canvas, R);

      finally
        Mask.Free;
      end;

    finally
      Composite.Free;
      Overlay.Free;
    end;

  end;

  if Length(Caption) > 0 then
  begin
    Canvas.Font := Self.Font;
    R := CLIENTRECT;
    DrawButtonText(Canvas, Caption, R, FState);
  end;

end;

function TMaskImgBtn.PtInMask(const X, Y: Integer): Boolean;
begin
  Result := True;
  if FHitTestMask <> nil then
    Result := (FHitTestMask.Canvas.Pixels[X, Y] = clBlack);
end;

procedure TMaskImgBtn.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var Clicked: Boolean;
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
      Clicked := PtInMask(X, Y);

    if Clicked then
    begin
      FState := bsDown;
      Repaint;
    end;
  end;
end;

procedure TMaskImgBtn.MouseMove(Shift: TShiftState; X, Y: Integer);
var NewState: TButtonState;
    InMask: Boolean;
begin
  inherited MouseMove(Shift, X, Y);
  InMask := PtInMask(X, Y);

  if FPreciseShowHint and not InMask then
  begin

    if not FPrevShowHintSaved then
    begin

      ParentShowHint := False;
      FPrevShowHint := ShowHint;
      ShowHint := False;
      FPrevShowHintSaved := True;
    end;
  end
  else IF not InMask then
  begin
    if not FPrevCursorSaved then
    begin
      FPrevCursor := Cursor;
      Cursor := crDefault;
      FPrevCursorSaved := True;
    end;
  end
  else
  begin
    if FPrevShowHintSaved then