hnoshape.pas

透明按钮 透明按钮 透明按钮

{$A+,B-,D+,F-,G+,I+,K+,L+,N+,P+,Q-,R-,S+,T-,V-,W-,X+,Y+}
unit HNoShape; { H = with highlight }
{mik 20/12/97 in-house unit}
interface

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

type
  THNoShape = class(TGraphicControl)
  private
    FAutoSize: Boolean;
    FBitmapIdle: TBitmap;
    FBitmapIdleUp: TBitmap;
    FBitmap: TBitmap;
    FBitmapUp: TBitmap;
    FBitmapDown: TBitmap;
    TempBitmap: TBitmap;
    FOver, Freallyover, Lastover : Boolean;
    property BitmapUp: TBitmap read FBitmapUp;
    property BitmapDown: TBitmap read FBitmapDown;
    property BitmapIdleUp: TBitmap read FBitmapIdleUp;
    procedure AdjustBounds;
    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 SetBitmapIdle(Value: TBitmap);
    procedure SetBitmapIdleUp(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;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Click; override;
    procedure Invalidate; override;
    function PtInMask(const X, Y: Integer): Boolean;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure mouseleave(var msg : tmessage); message cm_mouseleave;
    procedure mousein(var msg : tmessage); message cm_mouseenter;
  protected
    FState: TButtonState;
    procedure DefineProperties(Filer: TFiler); override;
    procedure DrawButtonText(Canvas: TCanvas; const Caption: String; TextBounds: TRect; State: TButtonState);
    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;
    procedure ReadBitmapIdleUpData(Stream: TStream); virtual;
    procedure WriteBitmapIdleUpData(Stream: TStream); virtual;
  published
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property IdleBitmap: TBitmap read FBitmapIdle write SetBitmapIdle;
    property Caption;
    property Enabled;
    property Font;
    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 Temp: TRect;
    OldBkColor: TColorRef;
    TmpBitmap : Tbitmap;
begin
  Makemask := nil;
  TmpBitmap := TBitmap.Create;
  try
    TmpBitmap.Monochrome := True;
    TmpBitmap.Width := ColorBmp.Width;
    TmpBitmap.Height := ColorBmp.Height;
    OldBkColor := SetBkColor(ColorBmp.Canvas.Handle, ColorToRGB(TransparentColor));
    Temp := Rect(0, 0, ColorBmp.Width, ColorBmp.Height);
    TmpBitmap.Canvas.CopyMode := cmSrcCopy;
    TmpBitmap.Canvas.CopyRect(Temp, ColorBmp.Canvas, Temp);
    SetBkColor(ColorBmp.Canvas.Handle, OldBkColor);
    MakeMask := TmpBitmap;
  except
    TmpBitmap.Free;
  end;

end;

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

    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;

constructor THNoShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetBounds(0, 0, 50, 50);
  ControlStyle := [csCaptureMouse, csOpaque];
  FAutoSize := True;
  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChanged;
  FBitmapUp := TBitmap.Create;
  FBitmapDown := TBitmap.Create;
  FBitmapIdle := Tbitmap.Create;
  FBitmapIdle.OnChange := BitmapChanged;
  FBitmapIdleUp := Tbitmap.Create;
  TempBitmap := nil;
  ParentFont := True;
  FState := bsUp;
end;

destructor THNoShape.Destroy;
begin
  FBitmap.Free;
  FBitmapUp.Free;
  FBitmapDown.Free;
  FBitmapIdle.Free;
  FBitmapIdleUp.Free;
  TempBitmap.Free;
  inherited Destroy;
end;

procedure THNoShape.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 Freallyover then begin
    if (FState = bsUp) then CurrentBmp := FBitmapUp
    else CurrentBmp := FBitmapDown;
  end else CurrentBmp:= FBitmapIdleUp;

  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 THNoShape.PtInMask(const X, Y: Integer): Boolean;
begin
  Result := True;
  if TempBitmap <> nil then
    Result := (TempBitmap.Canvas.Pixels[X, Y] = clBlack);
end;

procedure THNoShape.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 THNoShape.MouseMove(Shift: TShiftState; X, Y: Integer);
var NewState: TButtonState;
    InMask: Boolean;
begin
  inherited MouseMove(Shift, X, Y);
  InMask := PtInMask(X, Y);
  Freallyover := Fover and InMask;
  if Freallyover<>Lastover then begin
    Repaint;
    Lastover:=Freallyover;
  end;
end;

procedure THNoShape.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);
  DoClick := PtInMask(X, Y);
  if (FState = bsDown) then
    begin
      FState := bsUp;
      Repaint;
    end;
    if DoClick then Click;
end;

procedure THNoShape.Click;
begin
  inherited Click;
end;