一個有邊框的圖像組件

{
   *******  Tfhbimage  author:fhb 2008.9.25    *******
   www.fanhongbin.com
}
Tfhbimage = class(TImage)
  private
    { Private declarations }
    FEditLabel: TBoundLabel;
    FLabelPosition: TLabelPosition;
    FLabelSpacing: Integer;
    FEdgeCanvas: Tcanvas;
    FEdgePen: TPen;
    FEdgeBrush: TBrush;
    FfrmImageShow: TfrmImageShow;

    procedure SetupInternalLabel;
    procedure SetLabelPosition(const Value: TLabelPosition);
    procedure DrawEdge;
    procedure setEdgePen(const Value: TPen);
    procedure SetEdgeBrush(const Value: TBrush);

    function GetLeft: Integer;
    function GetHeight: Integer;
    function GetTop: Integer;
    function GetWidth: Integer;
    procedure SetLeft(const Value: Integer);
    procedure SetHeight(const Value: Integer);
    procedure SetTop(const Value: Integer);
    procedure SetWidth(const Value: Integer);
  protected
    { Protected declarations }
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetParent(AParent: TWinControl); override;
    procedure SetName(const Value: TComponentName); override;
    procedure DblClick; override;
    procedure Paint; override;
    procedure CMVisiblechanged(var Message: TMessage);message CM_VISIBLECHANGED;
    procedure CMEnabledchanged(var Message: TMessage);message CM_ENABLEDCHANGED;
    procedure CMBidimodechanged(var Message: TMessage);message CM_BIDIMODECHANGED;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged);message WM_WINDOWPOSCHANGED;
  public
    { Public declarations }
    procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer; AHeight: Integer); override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
     property ImageLabel: TBoundLabel read FEditLabel;
     property LabelPosition:TLabelPosition read FLabelPosition write SetLabelPosition default lpBelow;
     property EdgePen: TPen read FEdgePen write setEdgePen;
     property EdgeBrush: TBrush read FEdgeBrush write SetEdgeBrush;
     property ZoomWindow: TfrmImageShow read FfrmImageShow;
     property Left: Integer read GetLeft write SetLeft;
     property Top: Integer read GetTop write SetTop;
     property Width: Integer read GetWidth write SetWidth;
     property Height: Integer read GetHeight write SetHeight;
  end;



   procedure Register;

implementation

 const
    Distance: Integer = 4;

procedure Register;
begin
  RegisterComponents('fhbCP', [Tfhbimage]);
end;

{ Tfhbimage }
constructor Tfhbimage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FLabelPosition := lpBelow;
  FLabelSpacing := 6;
  SetupInternalLabel;
  FEdgeCanvas := TControlCanvas.Create;
  TControlCanvas(FEdgeCanvas).Control := Self;
  FEdgePen := FEdgeCanvas.Pen;
  FEdgeBrush := FEdgeCanvas.Brush;
  FfrmImageShow := TfrmImageShow.Create(Self);
  with FfrmImageShow do
  begin
    Height := 480;
    Width := 690;
    FfrmImageShow.Name := 'ZoomWindow';
    SetSubComponent(True);
  end;
  Self.Stretch := True;
end;


procedure Tfhbimage.SetLabelPosition(const Value: TLabelPosition);
var
  P: TPoint;
begin
  if FEditLabel = nil then exit;
  FLabelPosition := Value;
  case Value of
    lpAbove: P := Point(Left, (inherited Top) - FEditLabel.Height - FLabelSpacing);
    lpBelow: P := Point(Left, (inherited Top) + (inherited Height) + FLabelSpacing);
    lpLeft : P := Point(Left - FEditLabel.Width - FLabelSpacing,
                    (inherited Top) + (((inherited Height) - FEditLabel.Height) div 2));
    lpRight: P := Point(Left + (inherited Width) + FLabelSpacing,
                    (inherited Top) + (((inherited Height) - FEditLabel.Height) div 2));
  end;
  FEditLabel.SetBounds(P.x, P.y, FEditLabel.Width, FEditLabel.Height);
end;

procedure Tfhbimage.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
   inherited SetBounds(ALeft, ATop, AWidth, AHeight);
   SetLabelPosition(FLabelPosition);
end;

procedure Tfhbimage.SetupInternalLabel;
begin
  if Assigned(FEditLabel) then exit;
  FEditLabel := TBoundLabel.Create(Self);
  FEditLabel.FreeNotification(Self);
end;

procedure Tfhbimage.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if HasParent then Parent.Invalidate;
  if (AComponent = FEditLabel) and (Operation = opRemove) then
    FEditLabel := nil;
end;

procedure Tfhbimage.SetParent(AParent: TWinControl);
begin
  inherited SetParent(AParent);
  if FEditLabel = nil then exit;
  FEditLabel.Parent := AParent;
  FEditLabel.Visible := True;
end;

procedure Tfhbimage.SetName(const Value: TComponentName);
begin
   if (csDesigning in ComponentState) and ((FEditlabel.GetTextLen = 0) or
     (CompareText(FEditLabel.Caption, Name) = 0)) then
    FEditLabel.Caption := Value;
  inherited SetName(Value);
  if csDesigning in ComponentState then
    Text := '';
end;

procedure Tfhbimage.CMVisiblechanged(var Message: TMessage);
begin
  inherited;
  FEditLabel.Visible := Visible;
end;

procedure Tfhbimage.CMBidimodechanged(var Message: TMessage);
begin
  inherited;
  FEditLabel.BiDiMode := BiDiMode;
end;

procedure Tfhbimage.CMEnabledchanged(var Message: TMessage);
begin
  inherited;
  FEditLabel.Enabled := Enabled;
end;

procedure Tfhbimage.DblClick;
begin
  with   FfrmImageShow do
  begin
    Caption := FEditLabel.Caption;
    Graphic := Self.Picture.Graphic;
    ShowModal;
  end;
  inherited;
end;

procedure Tfhbimage.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if not (csDesigning in ComponentState) then
    DrawEdge;
end;

procedure Tfhbimage.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if not (csDesigning in ComponentState) then
  begin
   { with FEdgeCanvas do
    begin
      FEdgeCanvas.Pen.Mode := pmXor;
      Brush.Style := bsClear;
      Rectangle(Self.ClientRect);
    end;
    }
    Invalidate;
  end;

end;

procedure Tfhbimage.DrawEdge;
begin
    with FEdgeCanvas do
    begin
      Pen.Mode := pmCopy;
      Brush.Style := bsClear;
      Rectangle(Self.ClientRect);

      Polyline([Point(Left - 1, Top - 1), Point(Left + Width, Top -1)]);

    end;
end;

destructor Tfhbimage.Destroy;
begin
  FEdgeCanvas.Free;
  FfrmImageShow.Free;
  inherited;
end;

procedure Tfhbimage.setEdgePen(const Value: TPen);
begin
  if Value <> FEdgePen then
    FEdgePen.Assign(Value);
end;

procedure Tfhbimage.SetEdgeBrush(const Value: TBrush);
begin
  if Value <> FEdgeBrush then
    FEdgeBrush.Assign(Value);
end;

procedure Tfhbimage.Paint;
const
  XorColor = $00FFD8CE;
var
  BevelCans: TControlCanvas;
  Color1, Color2: TColor;

  procedure BevelRect(const R: TRect);
  begin
    with BevelCans do
    begin
      Pen.Mode := pmCopy;
      Pen.Color := Color1;
      PolyLine([Point(R.Left, R.Bottom), Point(R.Left, R.Top),
        Point(R.Right, R.Top)]);
      Pen.Color := Color2;
      PolyLine([Point(R.Right, R.Top), Point(R.Right, R.Bottom),
        Point(R.Left, R.Bottom)]);
    end;
  end;


begin
  inherited;
  Color1 := clBtnShadow;
  Color2 := clBtnHighlight;
  BevelCans := TControlCanvas.Create;
  try
    with BevelCans do
    begin
      Control := Parent;
      BevelRect(Rect((inherited Left) - Distance, (inherited Top) - Distance,
                      (inherited Left) + (inherited Width) + Distance,
                      (inherited Top) + (inherited Height) + Distance));

          //Canvas.Rectangle(Rect( 2, 2, Width - 8, height - 8));

    end;
  finally
    BevelCans.Free;
  end;
end;

procedure Tfhbimage.WMWindowPosChanged(var Message: TWMWindowPosChanged);
var
  i: Integer;
begin
  inherited;
  if HasParent then
  begin
    Parent.Invalidate;
    for i := 0 to Parent.ControlCount - 1 do
      if Parent.Controls[i] <> Self then
        Parent.Controls[i].Invalidate;
  end;
end;

function Tfhbimage.GetLeft: Integer;
begin
  Result := (inherited Left) - Distance;
end;

function Tfhbimage.GetHeight: Integer;
begin
  Result := (inherited Height) + 2 * Distance;
end;

function Tfhbimage.GetTop: Integer;
begin
  Result := (inherited Top) - Distance;
end;

function Tfhbimage.GetWidth: Integer;
begin
  Result := (inherited Width) + 2 * Distance;
end;

procedure Tfhbimage.SetLeft(const Value: Integer);
begin
  inherited Left := Value + Distance;
end;

procedure Tfhbimage.SetHeight(const Value: Integer);
begin
  inherited Height := Value - 2 * Distance;
end;

procedure Tfhbimage.SetTop(const Value: Integer);
begin
  inherited Top := Value + Distance;
end;

procedure Tfhbimage.SetWidth(const Value: Integer);
begin
  inherited Width := Value - 2 * Distance;
end;


end.

{
         ImageShow.Pas
}



type
  TfrmImageShow = class(TForm)
    Image1: TImage;
    procedure Image1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    FGraphic: TGraphic;
    procedure SetGraphic(const Value: TGraphic);
    { Private declarations }
  public
    { Public declarations }
    property Graphic:  TGraphic read FGraphic write SetGraphic;
  end;

implementation

{$R *.dfm}

procedure TfrmImageShow.Image1Click(Sender: TObject);
begin
  Self.Close;
end;

procedure TfrmImageShow.SetGraphic(const Value: TGraphic);
begin
  FGraphic := Value;
  Image1.Picture.Graphic := FGraphic;
end;

procedure TfrmImageShow.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action := caHide;
end;