fcimgbtn.pas

一套及时通讯的原码

unit fcImgBtn;
{
//
// Components : TfcImageBtn
//
// Copyright (c) 1999 by Woll2Woll Software
// 12/7/99 - Transfer patch variables to support bitmap palette
// 3/27/2002 - This can get called during destroy in which time the RegionData is invalid so exit.
}

interface

{$i fcIfDef.pas}

uses Windows, Messages, Classes, Controls, Forms, Graphics, StdCtrls,
  CommCtrl, Buttons, Dialogs, Math, Consts, SysUtils, fcCommon, fcText,
  fcButton, fcBitmap, fcChangeLink, fcImager
  {$ifdef fcDelphi4up}
  ,ImgList, ActnList
  {$endif};

type
  TfcDitherStyle = (dsDither, dsBlendDither, dsFill);

  TfcImgDownOffsets = class(TfcOffsets)
  private
    FImageDownX: Integer;
    FImageDownY: Integer;
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(AControl: TfcCustomBitBtn);
  published
    property ImageDownX: Integer read FImageDownX write FImageDownX default 2;
    property ImageDownY: Integer read FImageDownY write FImageDownY default 2;
  end;

  TfcCustomImageBtn = class (TfcCustomBitBtn)
  private
    // Property Storage Variables
    FDitherColor: TColor;
    FDitherStyle: TfcDitherStyle;
    FImage: TfcBitmap;
    FImageDown: TfcBitmap;
    FImageChangeLink: TfcChangeLink;
    FExtImage: TComponent;
    FExtImageDown: TComponent;
    FTransparentColor: TColor;

    // Property Access Methods
    function GetOffsets: TfcImgDownOffsets;
    function GetParentClipping: Boolean;
    function GetRespectPalette: Boolean;
    procedure SetDitherColor(Value: TColor);
    procedure SetDitherStyle(Value: TfcDitherStyle);
    procedure SetExtImage(Value: TComponent);
    procedure SetExtImageDown(Value: TComponent);
    procedure SetImage(Value: TfcBitmap);
    procedure SetImageDown(Value: TfcBitmap);
    procedure SetOffsets(Value: TfcImgDownOffsets);
    procedure SetParentClipping(Value: Boolean);
    procedure SetRespectPalette(Value: Boolean);
    procedure SetTransparentColor(Value: TColor);
  protected
    procedure Draw3DLines(SrcBitmap, DstBitmap: TfcBitmap; TransColor: TColor; Down: Boolean);

    procedure SetExtImages(Value: TComponent; var Prop: TComponent);

    // Virtual Methods
    procedure WndProc(var Message: TMessage); override;
    function CreateRegion(DoImplementation: Boolean; Down: Boolean): HRgn; override;
    function CreateOffsets: TfcOffsets; override;
    function GetTransparentColor(Down: Boolean): TColor;
    function ObtainImage(DownImage: Boolean): TfcBitmap; virtual;
    function StoreRegionData: Boolean; override;
    procedure AssignTo(Dest: TPersistent); override;
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
    procedure GetSizedImage(SourceBitmap: TfcBitmap; DestBitmap: TfcBitmap;
      ShadeStyle: TfcShadeStyle; ForRegion,DownFlag: Boolean); virtual;
    procedure ImageChanged(Sender: TObject); virtual;
    procedure ExtImageDestroying(Sender: TObject);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    function UseRegions: boolean; override;

  public
    Patch: Variant;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function ColorAtPoint(APoint: TPoint): TColor; virtual;
    function IsMultipleRegions: Boolean; override;
    procedure GetDrawBitmap(DrawBitmap: TfcBitmap; ForRegion: Boolean;
      ShadeStyle: TfcShadeStyle; Down: Boolean); override;
    procedure SplitImage; virtual;
    procedure SizeToDefault; override;

    // Public Properties
    property DitherColor: TColor read FDitherColor write SetDitherColor;
    property DitherStyle: TfcDitherStyle read FDitherStyle write SetDitherStyle;
    property ExtImage: TComponent read FExtImage write SetExtImage;
    property ExtImageDown: TComponent read FExtImageDown write SetExtImageDown;
    property Image: TfcBitmap read FImage write SetImage;
    property ImageDown: TfcBitmap read FImageDown write SetImageDown;
    property Offsets: TfcImgDownOffsets read GetOffsets write SetOffsets;
    property ParentClipping: Boolean read GetParentClipping write SetParentClipping;
    property RespectPalette: Boolean read GetRespectPalette write SetRespectPalette default False;
    property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
  end;

  TfcImageBtn = class(TfcCustomImageBtn)
  published
    {$ifdef fcDelphi4Up}
    property Action;
    property Anchors;
    property Constraints;
    {$endif}
    property AllowAllUp;
    property Cancel;
    property Caption;
    property Color;
    property Default;
    property DitherColor;
    property DitherStyle;
    property DragCursor;   //3/31/99 - PYW - Exposed DragCursor and DragKind properties.
    {$ifdef fcDelphi4Up}
    property DragKind;
    {$endif}
    property DragMode;
    property Down;
    property Font;
    property Enabled;
    property ExtImage;
    property ExtImageDown;
    property Glyph;
    property GroupIndex;
    property Image;
    property ImageDown;
    property Kind;
    property Layout;
    property Margin;
    property ModalResult;
    property NumGlyphs;
    property Offsets;
    property Options;
    property ParentClipping;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property RespectPalette;
    property ShadeColors;
    property ShadeStyle;
    property ShowHint;
    {$ifdef fcDelphi4Up}
    property SmoothFont;
    {$endif}
    property Style;
    property Spacing;
    property TabOrder;
    property TabStop;
    property TextOptions;
    property TransparentColor;
    property Visible;

    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseEnter;
    property OnMouseLeave;
    property OnMouseMove;
    property OnMouseUp;
    property OnSelChange;
    property OnStartDrag;
  end;

implementation

{$r-}

constructor TfcImgDownOffsets.Create(AControl: TfcCustomBitBtn);
begin
  inherited;
  FImageDownX := 2;
  FImageDownY := 2;
end;

procedure TfcImgDownOffsets.AssignTo(Dest: TPersistent);
begin
  if Dest is TfcImgDownOffsets then
    with Dest as TfcImgDownOffsets do
  begin
    ImageDownX := self.ImageDownX;
    ImageDownY := self.ImageDownY;
  end;
  inherited;
end;

constructor TfcCustomImageBtn.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  UseHalftonePalette:= True;
  FDitherColor := clWhite;
  FImage := TfcBitmap.Create;
  FImage.OnChange := ImageChanged;
  FImageDown := TfcBitmap.Create;
  FImageDown.OnChange := ImageChanged;
  FTransparentColor := clNone;
  FImageChangeLink := TfcChangeLink.Create;
  FImageChangeLink.OnChange := ImageChanged;
  Color := clNone;
end;

destructor TfcCustomImageBtn.Destroy;
begin
  FImage.Free;
  FImageDown.Free;
  FImageChangeLink.Free;
  inherited Destroy;
end;

function TfcCustomImageBtn.IsMultipleRegions: Boolean;
begin
  result := (not ObtainImage(False).Empty and not ObtainImage(True).Empty) or (ShadeStyle = fbsRaised);
  if result and (FTransparentColor=clNullColor) then result:= false;
end;

function TfcCustomImageBtn.StoreRegionData: Boolean;
begin
  result := True;
end;

// Added Down parameter to fix bug. - 4/6/99

function TfcCustomImageBtn.GetTransparentColor(Down: Boolean): TColor;
begin
  if FTransparentColor <> clNullColor then
  begin
    if FTransparentColor = clNone then
    begin
      if Down and not ObtainImage(True).Empty then
        result := fcGetStdColor(ObtainImage(True).Pixels[0, 0])
      else result:= fcGetStdColor(ObtainImage(False).Pixels[0, 0]);
      result := ColorToRGB(result) and $00FFFFFF;
    end else result := FTransparentColor;
  end else result := clNullColor;
end;

function TfcCustomImageBtn.ObtainImage(DownImage: Boolean): TfcBitmap;
begin
  if (not DownImage and (FExtImage <> nil)) and not (csDestroying in FExtImage.ComponentState) then
  begin
    result := Image;
    if FExtImage is TfcCustomImager then with FExtImage as TfcCustomImager do
    begin
      if WorkBitmap.Empty and not PictureEmpty then Resized;
      result := WorkBitmap;
    end else if FExtImage is TfcCustomImageBtn then with FExtImage as TfcCustomImageBtn do
      result := Image;
  end else if DownImage and (FExtImageDown <> nil) and not (csDestroying in FExtImageDown.ComponentState) then
  begin
    result := ImageDown;
    if FExtImageDown is TfcCustomImager then with FExtImageDown as TfcCustomImager do
    begin
      if WorkBitmap.Empty and not PictureEmpty then Resized;
      result := WorkBitmap;
    end else if FExtImageDown is TfcCustomImageBtn then with FExtImageDown as TfcCustomImageBtn do
      result := ImageDown;
  end else if DownImage then result := ImageDown
  else result := Image;
end;

function TfcCustomImageBtn.CreateOffsets: TfcOffsets;
begin
  result := TfcImgDownOffsets.Create(self);
end;

function TfcCustomImageBtn.CreateRegion(DoImplementation: Boolean; Down: Boolean): HRgn;
var SizedImage: TfcBitmap;
    Rgn: HRGN;
begin
  if TransparentColor = clNullColor then
  begin
    result := 0;
    Exit;
  end;

  result := inherited CreateRegion(False, Down);
  if not DoImplementation or (result <> 0) or ObtainImage(False).Empty then Exit;

  SizedImage := TfcBitmap.Create;
  SizedImage.RespectPalette := RespectPalette;
  GetSizedImage(ObtainImage(Down and not ObtainImage(True).Empty), SizedImage, ShadeStyle, True, Down);

  result := fcRegionFromBitmap(SizedImage, GetTransparentColor(Down));

  if ShadeStyle = fbsRaised then
  begin
    Rgn := CreateRectRgn(0, 0, 10, 10);
    if CombineRgn(Rgn, result, 0, RGN_COPY) = ERROR then Exit;
    OffsetRgn(Rgn, 2, 2);
    if Down then CombineRgn(result, Rgn, 0, RGN_COPY)
    else CombineRgn(result, Rgn, result, RGN_OR);
    DeleteObject(Rgn);
  end;

  SizedImage.Free;

  SaveRegion(result, Down);
end;

procedure TfcCustomImageBtn.SetDitherColor(Value: TColor);
begin
  if FDitherColor <> Value then
  begin
    FDitherColor := Value;
    Invalidate;
  end;
end;

procedure TfcCustomImageBtn.SetDitherStyle(Value: TfcDitherStyle);
begin
  if FDitherStyle <> Value then
  begin
    FDitherStyle := Value;
    Invalidate;
  end;
end;

procedure TfcCustomImageBtn.SetImage(Value: TfcBitmap);
begin
  if Value <> nil then ExtImage := nil;
  FImage.Assign(Value);
  if not Down or ObtainImage(True).Empty then RecreateWnd;
end;

procedure TfcCustomImageBtn.SetImageDown(Value: TfcBitmap);
begin
  if Value <> nil then ExtImageDown := nil;
  FImageDown.Assign(Value);
  if Down then RecreateWnd;
end;

procedure TfcCustomImageBtn.SetExtImages(Value: TComponent; var Prop: TComponent);
begin
  if Prop <> nil then
  begin
    if Prop is TfcCustomImager then (Prop as TfcCustomImager).UnRegisterChanges(FImageChangeLink)
    else if Prop is TfcCustomImageBtn then (Prop as TfcCustomImageBtn).UnRegisterChanges(FImageChangeLink);
  end;
  Prop := Value;
  if Value <> nil then
  begin
    if Value is TfcCustomImager then (Value as TfcCustomImager).RegisterChanges(FImageChangeLink)
    else if Value is TfcCustomImageBtn then (Value as TfcCustomImageBtn).Image.RegisterChanges(FImageChangeLink);
    Value.FreeNotification(self);
  end;

  RecreateWnd;
end;

procedure TfcCustomImageBtn.SetExtImage(Value: TComponent);
begin
  if Value <> nil then Image.Clear;
  SetExtImages(Value, FExtImage);
end;

procedure TfcCustomImageBtn.SetExtImageDown(Value: TComponent);
begin
  if Value <> nil then ImageDown.Clear;
  SetExtImages(Value, FExtImageDown);
end;

procedure TfcCustomImageBtn.Draw3DLines(SrcBitmap, DstBitmap: TfcBitmap; TransColor: TColor; Down: Boolean);
var WorkingBm{, DstBm}: TfcBitmap;
    DstPixels, SrcPixels: PfcPLines;
    StartPt, EndPt, OldEndPt: TPoint;
    Col, Row: Integer;
    ABtnHighlight, ABtn3DLight, ABtnShadow, ABtnBlack: TfcColor;
    BitmapSize: TSize;
  function CheckPoint(p: TPoint): TPoint;
  begin
    result := p;
    if result.x < 0 then result.x := 0;
    if result.y < 0 then result.y := 0;
    if result.x > BitmapSize.cx - 1 then result.x := BitmapSize.cx - 1;
    if result.y > BitmapSize.cy - 1 then result.y := BitmapSize.cy - 1;
  end;
  function PointValid(x, y: Integer): Boolean;
  begin
    result := not ((x < 0) or (y < 0) or
      (x >= BitmapSize.cx) or (y >= BitmapSize.cy));
  end;
  procedure GetFirstPixelColor(CurrentCol, CurrentRow: Integer; var ResultPt: TPoint; AColor: TColor; NotColor: Boolean; SearchForward: Boolean);
  var i, MaxIncr: Integer;
      CurColor: TColor;
  begin
    if SearchForward then MaxIncr := fcMin(BitmapSize.cx - CurrentCol, BitmapSize.cy - CurrentRow)
    else MaxIncr := fcMin(CurrentCol, CurrentRow);
    for i := 0 to MaxIncr - 1 do
    begin
      with SrcPixels[CurrentRow, CurrentCol] do CurColor := RGB(r, g, b);
      if ((CurColor = AColor) and not NotColor) or
         ((CurColor <> AColor) and NotColor) then
      begin