Delphi控件源码

开发平台：
Delphi

VrShapeBtn.pas：源码内容
							{*****************************************************}
{                                                     }
{     Varian Component Workshop                       }
{                                                     }
{     Varian Software NL (c) 1996-2000                }
{     All Rights Reserved                             }
{                                                     }
{*****************************************************}
unit VrShapeBtn;
{$I VRLIB.INC}
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  VrControls, VrSysUtils;
type
  TVrShapeBtn = class(TVrGraphicImageControl)
  private
    FBitmap: TBitmap;
    FBitmapUp: TBitmap;
    FBitmapDown: TBitmap;
    FMaskBitmap: TBitmap;
    FDown, FPressed: Boolean;
    procedure AdjustBounds;
    function BevelColor(Pressed: Boolean; const TopLeft: Boolean): TColor;
    procedure Create3DBitmap(Source: TBitmap; Pressed: Boolean; Target: TBitmap);
    procedure SetBitmap(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;
    function PtInMask(const X, Y: Integer): Boolean;
    procedure BitmapChanged(Sender: TObject);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    function GetPalette: HPALETTE; override;
    procedure Loaded; override;
    procedure CreateMaskBitmap;
    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 Click; override;
    procedure ReadBitmapData(Stream: TStream); virtual;
    procedure WriteBitmapData(Stream: TStream); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  published
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property Transparent;
{$IFDEF VER110}
    property Anchors;
    property Constraints;
{$ENDIF}
    property Caption;
    property DragCursor;
{$IFDEF VER110}
    property DragKind;
{$ENDIF}
    property DragMode;
    property Enabled;
    property Font;
    property ParentFont default false;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property OnClick;
{$IFDEF VER130}
    property OnContextPopup;
{$ENDIF}
    property OnDragDrop;
    property OnDragOver;
{$IFDEF VER110}
    property OnEndDock;
{$ENDIF}
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
{$IFDEF VER110}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;
implementation
type
  Apair = array[0..1] of Integer;
function MakeBorder(Source, NewSource: TBitmap; const OffsetPts: array of Apair;
  TransparentColor: TColor): TBitmap;
var
  I : Integer;
  R, NewR: TRect;
  SmallMask, BigMask, NewSourceMask: TBitmap;
  function GetMask(Source: TBitmap; TransColor: TColor): TBitmap;
  begin
    Result := TBitmap.Create;
    try
      Result.Assign(Source);
      Result.Mask(TransColor);
    except
      Result.Free;
      raise;
    end;
  end;
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 := GetMask(Source, TransparentColor);
    NewSourceMask := GetMask(NewSource, TransparentColor);
    BigMask := GetMask(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);
      end;
    finally
      SmallMask.Free;
      NewSourceMask.Free;
      BigMask.Free;
    end;
  except
    Result.Free;
    Raise;
  end;
end;
constructor TVrShapeBtn.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 50;
  Height := 50;
  ControlStyle := ControlStyle + [csCaptureMouse, csOpaque] - [csDoubleClicks];
  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChanged;
  FBitmapUp := TBitmap.Create;
  FBitmapDown := TBitmap.Create;
  FMaskBitmap := TBitmap.Create;
  ParentFont := True;
end;
destructor TVrShapeBtn.Destroy;
begin
  FBitmap.Free;
  FBitmapUp.Free;
  FBitmapDown.Free;
  FMaskBitmap.Free;
  inherited Destroy;
end;
procedure TVrShapeBtn.Loaded;
begin
  inherited Loaded;
  CreateMaskBitmap;
end;
procedure TVrShapeBtn.CreateMaskBitmap;
begin
  if not FBitmap.Empty then
  begin
    FMaskBitmap.Assign(FBitmap);
    FMaskBitmap.Mask(FBitmap.TransparentColor);
  end;
end;
procedure TVrShapeBtn.AdjustBounds;
begin
  SetBounds(Left, Top, Width, Height);
end;
procedure TVrShapeBtn.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var W, H: Integer;
begin
  W := AWidth;
  H := AHeight;
  if FBitmap <> nil then
    if not (csLoading in ComponentState) and (not FBitmap.Empty) then
    begin
      W := FBitmap.Width;
      H := FBitmap.Height;
    end;
  inherited SetBounds(ALeft, ATop, W, H);
end;
procedure TVrShapeBtn.Paint;
var
  R: TRect;
  CurrentBmp: TBitmap;
begin
  ClearBitmapCanvas;
  if (not FPressed) then CurrentBmp := FBitmapUp
  else CurrentBmp := FBitmapDown;
  with BitmapCanvas do
  begin
    if not CurrentBmp.Empty then
    begin
      R := BitmapRect(BitmapImage);
      if FPressed then OffsetRect(R, 1, 1);
      Brush.Color := FBitmap.TransparentColor;
      if Transparent then Brush.Style := bsClear
      else Brush.Style := bsSolid;
      BrushCopy(R, CurrentBmp, BitmapRect(CurrentBmp),
        FBitmap.TransparentColor);
    end;
    if Length(Caption) > 0 then
    begin
      R := ClientRect;
      Font := Self.Font;
      Brush.Style := bsClear;
      if FPressed then OffsetRect(R, 1, 1);
      DrawText(BitmapCanvas.Handle, PChar(Caption), -1, R,
        DT_CENTER or DT_VCENTER or DT_SINGLELINE);
    end;
  end;
  ShowDesignFrame(BitmapCanvas);
  inherited Paint;
end;
procedure TVrShapeBtn.Click;
begin
end;
function TVrShapeBtn.PtInMask(const X, Y: Integer): Boolean;
begin
  Result := True;
  if FMaskBitmap <> nil then
    Result := (FMaskBitmap.Canvas.Pixels[X, Y] = clBlack);
end;
procedure TVrShapeBtn.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  Clicked: Boolean;
begin
  if (Button = mbLeft) and Enabled then
  begin
    Clicked := PtInMask(X, Y);
    if Clicked then
    begin
      FDown := True;
      FPressed := True;
      UpdateControlCanvas;
    end;
  end;
  inherited MouseDown(Button, Shift, X, Y);
end;
procedure TVrShapeBtn.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  OldValue: Boolean;
begin
  OldValue := FPressed;
  FPressed := FDown and PtInMask(X, Y);
  if FPressed <> OldValue then
    UpdateControlCanvas;
  inherited MouseMove(Shift, X, Y);
end;
procedure TVrShapeBtn.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  DoClick := false;
  if FDown then
  begin
    DoClick := PtInMask(X, Y);
    FDown := false;
    FPressed := false;
    UpdateControlCanvas;
  end;
  inherited MouseUp(Button, Shift, X, Y);
  if DoClick then inherited Click;
end;
function TVrShapeBtn.GetPalette: HPALETTE;
begin
  Result := FBitmap.Palette;
end;
procedure TVrShapeBtn.SetBitmap(Value: TBitmap);
begin
  FBitmap.Assign(Value);
end;
procedure TVrShapeBtn.BitmapChanged(Sender: TObject);
var
  OldCursor: TCursor;
  W, H: Integer;
begin
  AdjustBounds;
  if not ((csReading in ComponentState) or (csLoading in ComponentState)) then
  begin
    if FBitmap.Empty then
    begin
      FBitmapUp.Assign(nil);
      FBitmapDown.Assign(nil);
    end
    else
    begin
      W := FBitmap.Width;
      H := FBitmap.Height;
      OldCursor := Screen.Cursor;
      Screen.Cursor := crHourGlass;
      try
        FBitmapUp.Width := W;
        FBitmapUp.Height := H;
        FBitmapDown.Width := W;
        FBitmapDown.Height := H;
        Create3DBitmap(FBitmap, False, FBitmapUp);
        Create3DBitmap(FBitmap, True, FBitmapDown);
        CreateMaskBitmap;
      finally
        Screen.Cursor := OldCursor;
      end;
    end;
  end;
  UpdateControlCanvas;
end;
procedure TVrShapeBtn.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(CharCode, Caption) and Enabled then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;
procedure TVrShapeBtn.CMFontChanged(var Message: TMessage);
begin
  inherited;
  UpdateControlCanvas;
end;
procedure TVrShapeBtn.CMTextChanged(var Message: TMessage);
begin
  inherited;
  UpdateControlCanvas;
end;
procedure TVrShapeBtn.CMSysColorChange(var Message: TMessage);
begin
  inherited;
  BitmapChanged(Self);
end;
function TVrShapeBtn.BevelColor(Pressed: Boolean; const TopLeft: Boolean): TColor;
begin
  if (not Pressed) then
  begin
    if TopLeft then Result := clBtnHighlight
    else Result := clBtnShadow
  end
  else { bsDown }
  begin
    if TopLeft then Result := clBtnShadow
    else Result := clBtnHighlight;
  end;
end;
procedure TVrShapeBtn.Create3DBitmap(Source: TBitmap;
  Pressed: Boolean; Target: TBitmap);
type
  OutlineOffsetPts = array[1..3, 0..1, 0..12] of Apair;
const
  OutlinePts: OutlineOffsetPts =
    ( (((1,-1),(1,0),(1,1),(0,1),(-1,1),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0)),
       ((-1,0),(-1,-1),(0,-1),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0))),
      (((2,-2),(2,-1),(2, 0),(2, 1),(2, 2),(1, 2),(0, 2),(-1,2),(-2,2),(0,0),(0,0),(0,0),(0,0)),
       ((-2,1),(-2,0),(-2,-1),(-2,-2),(-1,-2),(0,-2),(1,-2),(0,0),(0,0),(0,0),(0,0),(0,0),(0,0))),
      (((3,-3),(3,-2),(3,-1),(3,0),(3,1),(3,2),(3,3),(2,3),(1,3),(0,3),(-1,3),(-2,3),(-3,3)),
       ((-3,2),(-3,1),(-3,0),(-3,-1),(-3,-2),(-3,-3),(-2,-3),(-1,-3),(0,-3),(1,-3),(2,-3),(0,0),(0,0)))
    );
var
  I, J, W, H, Outlines: Integer;
  R: TRect;
  OutlineMask, Overlay, NewSource: TBitmap;
begin
  if (Source = nil) or (Target = nil) then
    Exit;
  W := Source.Width;
  H := Source.Height;
  R := Rect(0, 0, W, H);
  Overlay := TBitmap.Create;
  NewSource := TBitmap.Create;
  try
    NewSource.Width := W;
    NewSource.Height := H;
    Target.Canvas.CopyMode := cmSrcCopy;
    Target.Canvas.CopyRect(R, Source.Canvas, R);
    Overlay.Width := W;
    Overlay.Height := H;
    Outlines := 2;
    for I := 1 to Outlines do
    begin
      with NewSource.Canvas do
      begin
        CopyMode := cmSrcCopy;
        CopyRect(R, Target.Canvas, R);
      end;
      for J := 0 to 1 do
      begin
        if (Pressed) and (I = Outlines) and (J = 0) then
          Continue;
        OutlineMask := MakeBorder(Source, NewSource, OutlinePts[I, J],
                        FBitmap.TransparentColor);
        try
          with Overlay.Canvas do
          begin
            if (I = Outlines)  then
              Brush.Color := clBlack
            else
              Brush.Color := BevelColor(Pressed, (J = 1));
            CopyMode := $0030032A; { PSna }
            CopyRect(R, OutlineMask.Canvas, R);
          end;
          with Target.Canvas do
          begin
            CopyMode := cmSrcAnd; { DSa }
            CopyRect(R, OutlineMask.Canvas, R);
            CopyMode := cmSrcPaint; { DSo }
            CopyRect(R, Overlay.Canvas, R);
            CopyMode := cmSrcCopy;
          end;
        finally
          OutlineMask.Free;
        end;
      end;
    end;
  finally
    Overlay.Free;
    NewSource.Free;
  end;
end;
procedure TVrShapeBtn.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('BitmapData', ReadBitmapData, WriteBitmapData, True);
end;
procedure TVrShapeBtn.ReadBitmapData(Stream: TStream);
begin
  FBitmapUp.LoadFromStream(Stream);
  FBitmapDown.LoadFromStream(Stream);
end;
procedure TVrShapeBtn.WriteBitmapData(Stream: TStream);
begin
  FBitmapUp.SaveToStream(Stream);
  FBitmapDown.SaveToStream(Stream);
end;
end.

						