mshape.pas

能够显示多种图形效果的构件太好用了！！方便

{-------------------------------------------------------------------}
{ MULTISHAPE - VCL component to create graphic effects v.1.00       }
{-------------------------------------------------------------------}
{ v. 1.00 April, 4 1996                                             }
{-------------------------------------------------------------------}
{ Copyright Enrico Lodolo                                           }
{ via F.Bolognese 27/3 - 40129 Bologna - Italy                      }
{ CIS 100275,1255 - Internet [e-mail]                 }
{-------------------------------------------------------------------}

unit MShape;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

const DefSize=10;
      DefSpacing=20;
      DefShadowOfs=2;

type TMultiShapeType=
       (msRectangle,msRoundRect,msDiamond,msEllipse,
        msTriangle,msLine,msText);
     TRepeatMode=(rpNone,rpVert,rpHoriz,rpBoth);

type TShapeStr=string[255];

type
  TMultiShape = class(TGraphicControl)
  private
    FAngle:Integer;
    FAutoSize:Boolean;
    FNewFont,FOldFont:HFont;
    FDX,FDY:Integer;
    FFilled:Boolean;
    FRepeatMode:TRepeatMode;
    FShapeType:TMultiShapeType;
    FShapeH:Integer;
    FShapeW:Integer;
    FXSpacing:Integer;
    FYSpacing:Integer;
    FXMargin:Integer;
    FYMargin:Integer;
    FBorder:Boolean;
    FBorderColor:TColor;
    FBorderWidth:Integer;
    FShadow:Boolean;
    FShadowColor:TColor;
    FShadowX:Integer;
    FShadowY:Integer;
    procedure CMTextChanged(var Message: TMessage);
      message CM_TEXTCHANGED;
    procedure CMFontChanged(var Message: TMessage);
      message CM_FONTCHANGED;
    procedure CMColorChanged(var Message: TMessage);
      message CM_COLORCHANGED;
  protected
    {-- Property Handlers --------------------------------}
    procedure SetAngle(Value:Integer);
    procedure SetAutoSize(Value:Boolean);
    procedure SetFilled(Value:Boolean);
    procedure SetRepeatMode(Value:TRepeatMode);
    procedure SetShapeType(Value:TMultiShapeType);
    procedure SetShapeH(Value:Integer);
    procedure SetShapeW(Value:Integer);
    procedure SetXSpacing(Value:Integer);
    procedure SetYSpacing(Value:Integer);
    procedure SetXMargin(Value:Integer);
    procedure SetYMargin(Value:Integer);
    procedure SetBorder(Value:Boolean);
    procedure SetBorderColor(Value:TColor);
    procedure SetBorderWidth(Value:Integer);
    procedure SetShadow(Value:Boolean);
    procedure SetShadowColor(Value:TColor);
    procedure SetShadowX(Value:Integer);
    procedure SetShadowY(Value:Integer);
    {-- Protected methods --------------------------------}
    procedure PrepareText;
    procedure UnprepareText;
    procedure AdjustShapeSize;
    procedure AdjustControlSize;
    procedure DrawRectangle(X,Y:Integer);
    procedure DrawRoundRect(X,Y:Integer);
    procedure DrawDiamond(X,Y:Integer);
    procedure DrawEllipse(X,Y:Integer);
    procedure DrawTriangle(X,Y:Integer);
    procedure DrawLine(X,Y:Integer);
    procedure DrawText(X,Y:Integer);
    procedure Paint; override;
    property AutoSize:Boolean read FAutoSize write SetAutoSize;
  public
    procedure SetBounds(ALeft,ATop,AWidth,AHeight:Integer); override;
  published
    constructor Create(AOwner:TComponent); override;
    property Align;
    property Color;
    property Font;
    property ParentColor;
    property ParentFont;
    property Text;
    property Angle:Integer read FAngle write SetAngle;
    property Filled:Boolean
      read FFilled write SetFilled default True;
    property RepeatMode:TRepeatMode
      read FRepeatMode write SetRepeatMode default rpBoth;
    property ShapeType:TMultiShapeType
      read FShapeType write SetShapeType;
    property ShapeH:Integer
      read FShapeH write SetShapeH default DefSize;
    property ShapeW:Integer
      read FShapeW write SetShapeW default DefSize;
    property XSpacing:Integer
      read FXSpacing write SetXSpacing default DefSpacing;
    property YSpacing:Integer
      read FYSpacing write SetYSpacing default DefSpacing;
    property XMargin:Integer
      read FXMargin write SetXMargin;
    property YMargin:Integer
      read FYMargin write SetYMargin;
    property Border:Boolean
      read FBorder write SetBorder;
    property BorderColor:TColor
      read FBorderColor write SetBorderColor default clBlack;
    property BorderWidth:Integer
      read FBorderWidth write SetBorderWidth default 1;
    property Shadow:Boolean
      read FShadow write SetShadow;
    property ShadowColor:TColor
      read FShadowColor write SetShadowColor default clGray;
    property ShadowX:Integer
      read FShadowX write SetShadowX default DefShadowOfs;
    property ShadowY:Integer
      read FShadowY write SetShadowY default DefShadowOfs;
  end;

procedure Register;

implementation

{--------------------------------------------------------------}
{                       Message Handlers                       }
{--------------------------------------------------------------}

procedure TMultiShape.CMTextChanged(var Message:TMessage);

begin
     Invalidate;
end;

procedure TMultiShape.CMFontChanged(var Message:TMessage);

begin
     inherited;
     Color:=Font.Color;
end;

procedure TMultiShape.CMColorChanged(var Message:TMessage);

begin
     inherited;
     Font.Color:=Color;
end;

{--------------------------------------------------------------}
{                         Basic methods                        }
{--------------------------------------------------------------}

procedure TMultiShape.AdjustShapeSize;

begin
     if FAutoSize then
       begin
         FShapeW:=Width-FXMargin*2;
         FShapeH:=Height-FYMargin*2;
         if Shadow then
           begin
             Dec(FShapeW,ShadowX);
             Dec(FShapeH,ShadowY);
           end;
       end;
end;

procedure TMultiShape.AdjustControlSize;

var H,W:Integer;

begin
     if FAutoSize then
       begin
         W:=FShapeW+FXMargin*2;
         H:=FShapeH+FYMargin*2;
         if FShadow then
           begin
             Inc(W,ShadowX);
             Inc(H,ShadowY);
           end;
         Width:=W;
         Height:=H;
       end;
end;

procedure TMultiShape.SetBounds(ALeft,ATop,AWidth,AHeight:Integer);

begin
     inherited SetBounds(ALeft,ATop,AWidth,AHeight);
     AdjustShapeSize;
end;

{--------------------------------------------------------------}
{                       Property Handlers                      }
{--------------------------------------------------------------}

procedure TMultiShape.SetAngle(Value:Integer);

begin
     if Value<>FAngle then
       begin
         FAngle:=Value;
         {-- Normalization: -179