rotatelabel1.~pas

田民格设计Delphi旋转控件

unit RotateLabel1;
{ This component works like TLabel and has 2 additional properties:        }
{ Escapement: draw text with angle (0..360 deg)                            }
{             selected font must be a TrueType!!!                          }
{ TextStyle:  draw text with 3D-effects  tsRecessed                        }
{                                        tsRaised                          }
{                                        tsNone                            }
interface

uses
  Windows,WinProcs, Wintypes, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Menus,math;

type
  TTextStyle = (tsNone,tsRaised,tsRecessed);
  Ttx=(txNone,txEllipse,txRectangle,txRoundRect,txWjx,txNorth,txArrow,txCross);//图形类型
  TBorderKind = (tbLeft,tbRight,tbTop,tbBottom);//文本边框
  TBorderLine = set of TBorderKind;
  TAlignmentH = (ahTop,ahCenter,ahBottom);

  TRotateLabel = class(TLabel)
   private
    fEscapement : Integer;
    fTextStyle  : TTextStyle;//Cx,Cy:integer;
    fCx,fCy:integer;ftbColor:TColor;//文本边框颜色
    fBrushColor:TColor;fBrushstyle:TBrushstyle;
    fBorderLine: TBorderLine;
    ftx:Ttx; ffAnchors:TAnchors;fAlignmentH:TAlignmentH;
    procedure   SetEscapement(aVal:Integer);
    procedure   SetTextStyle (aVal:TTextStyle);
    procedure   CalcTextPos(var aRect:TRect;aAngle:Integer;aTxt:String);
    procedure   DrawAngleText(aCanvas:TCanvas;aRect:TRect;aAngle:Integer;aTxt:String);
    procedure   SetfBorderLine(Value:TBorderLine);
    procedure   SetftbColor(aVal:TColor);
    procedure   SetfBrushColor(aVal:TColor);
    procedure   SetfBrushStyle(aVal:TBrushStyle);
    procedure   SetfCx(aVal:Integer);
    procedure   SetfCy(aVal:Integer);
    procedure   Setftx(aVal:Ttx);
    procedure   Wjx(Rect:TRect);//画实心五角星
    procedure   North(aRect:TRect);//画指北针
    procedure   arrow(aRect:TRect);//画箭头针
    procedure   Cross(aRect:TRect);//画箭头针
    procedure SetAnchors(Value: TAnchors);// override;
    procedure SetfAlignmentH(aVal:TAlignmentH);
   protected
    procedure   DoDrawText(var Rect:TRect;Flags:Word);
    procedure   Paint; override;
   public
    P:array[0..4] of TPoint;
    constructor Create(AOwner: TComponent);overLoad;override;
    constructor Create(AOwner:TComponent;Text:string;tx:Ttx;L:integer=0;T:integer=0;W:integer=50;H:integer=20;Angle:integer=0);overLoad;
    destructor Destroy; override;
   published
    property Anchors2: TAnchors read fFAnchors write SetAnchors default [akLeft, akTop];
    property AlignmentH:TAlignmentH read fAlignmentH write SetfAlignmentH default ahTop;
    property Escapement: Integer read fEscapement write SetEscapement default 45;
    property TextStyle : TTextStyle read fTextStyle  write SetTextStyle default tsRaised;
    property BorderColor:TColor read ftbColor write SetftbColor default clBlack;
    property BrushColor:TColor read fBrushColor write SetfBrushColor default clBlack;
    property BrushStyle:TBrushStyle read fBrushStyle write SetfBrushStyle default bsClear;
    property BorderLine: TBorderLine read fBorderLine write SetfBorderLine default [];
    property Cx: Integer read fCx write SetfCx default 128;
    property Cy: Integer read fCy write SetfCy default 16;
    property TX : Ttx read ftx  write Setftx default txNone;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Standard', [TRotateLabel]);
end;

constructor TRotateLabel.Create(aOwner:TComponent);
begin
  inherited Create(aOwner);Transparent:=True;
  fEscapement:=45;fTextStyle:=tsRaised;Caption:='田民格制旋转标签';
  ffAnchors:=[akLeft,akTop];fBrushStyle:=bsClear;
  //Hint:='更改TX等属性可显示各种图形';ShowHint:=True;
  Font.Size:=12;Font.Name:='宋体';//Font.Color:=clblue;
end;
constructor TRotateLabel.Create(aOwner:TComponent;Text:string;tx:Ttx;L:integer=0;T:integer=0;W:integer=50;H:integer=20;Angle:integer=0);
begin
 inherited Create(aOwner);AutoSize:=false;Caption:=Text;fTextStyle:=tsRaised;
 fCy:=H;fCx:=W;Top:=T;Left:=L;Height:=H;Width:=W;fEscapement:=Angle;
 ffAnchors:=[akLeft,akTop];Transparent:=True;fBrushStyle:=bsClear;
 Font.Size:=12;Font.Name:='宋体';ftx:=tx;
 case tx of//txNone,txEllipse,,txRoundRect:Begin End;
 txRectangle:Begin Width:=50;Height:=25;Cx:=50;Cy:=25;
             fEscapement:=1;fAlignmentH:=ahCenter;End;
 txWjx:Begin fBrushColor:=clRed;ftbColor:=clRed;fBrushStyle:=bsSolid;
             Width:=21;Height:=21;fCx:=20;fCy:=20;End;
 txNorth:Begin Width:=31;Height:=61;Cx:=30;Cy:=60;fBrushStyle:=bsSolid;End;
 txArrow:Begin Width:=20;Height:=41;Cx:=20;Cy:=40;fBrushStyle:=bsClear;End;
 txCross:Begin fBrushColor:=clRed;ftbColor:=clRed;fBrushStyle:=bsSolid;
              Width:=23;Height:=23;Cx:=22;Cy:=22;End;
 end;
end;

destructor TRotateLabel.Destroy;
Begin
inherited Destroy;
End;

procedure TRotateLabel.SetAnchors(Value: TAnchors);
begin
  if fFAnchors <> Value then
  begin
   ffAnchors:=Value;//Anchors:=Value;
    Invalidate;
  end;
end;

procedure TRotateLabel.SetfAlignmentH(aVal:TAlignmentH);
begin if fAlignmentH=aVal then exit;fAlignmentH:=aVal;Invalidate;end;
procedure TRotateLabel.SetftbColor(aVal:TColor);
begin if ftbColor=aVal then exit;ftbColor:=aVal;Invalidate;end;
procedure TRotateLabel.SetfBrushColor(aVal:TColor);
begin if fBrushColor=aVal then exit;fBrushColor:=aVal;Invalidate;end;
procedure TRotateLabel.SetfBrushStyle(aVal:TBrushStyle);
begin if fBrushStyle=aVal then exit;fBrushStyle:=aVal;Invalidate;end;
procedure TRotateLabel.SetfBorderLine(Value: TBorderLine);
begin if fBorderLine<>Value then begin fBorderLine:=Value;Invalidate;end;end;
procedure TRotateLabel.SetfCx(aVal:Integer);
begin if fCx=aVal then exit;fCx:=aVal;Invalidate;end;
procedure TRotateLabel.SetfCy(aVal:Integer);
begin if fCy=aVal then exit;fCy:=aVal;Invalidate;end;
procedure TRotateLabel.Setftx(aVal:Ttx);
begin if ftx=aVal then exit;ftx:=aVal;Invalidate;end;

procedure TRotateLabel.SetEscapement(aVal:Integer);
begin
  if fEscapement=aVal then exit;
  while aVal<0 do aVal:=aVal+360;while aVal>=360 do aVal:=aVal-360;
  fEscapement:=aVal;Invalidate;
end;

procedure TRotateLabel.SetTextStyle(aVal:TTextStyle);
begin
  if fTextStyle<>aVal then begin fTextStyle:=aVal;Invalidate;end;
end;

procedure TRotateLabel.Paint;
const
  Alignments:array[TAlignment] of Word=(DT_LEFT,DT_RIGHT,DT_CENTER);
  WordWraps:array[Boolean] of Word=(0,DT_WORDBREAK);
var Rect:TRect;
begin
 with Canvas do begin
  if not Transparent then
   begin Brush.Color:=Color;Brush.Style:=bsSolid;FillRect(ClientRect);end;
  Brush.Style:=bsClear;Rect:=ClientRect;
  if Alignment=taLeftJustify then P[0].X:=Rect.Left Else
  if Alignment=taCenter then P[0].X:=Rect.Left+(Width-fCx)div 2 Else
  if Alignment=taRightJustify then P[0].X:=Rect.Left+Width-fCx-1;
  if fAlignmentH=ahTop then P[0].Y:=Rect.Top Else
  if fAlignmentH=ahCenter then P[0].Y:=Rect.Top+(Height-fCy)div 2 Else
  if fAlignmentH=ahBottom then P[0].Y:=Rect.Top+Height-fCy-1;
  P[1]:=Point(P[0].X,P[0].Y+fCy);//Rect.TopLeft:=P[0];
  P[2]:=Point(P[0].X+fCx,P[0].Y+fCy);P[3]:=Point(P[0].X+fCx,P[0].Y);
  DoDrawText(Rect,DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment]);
  Pen.Color:=ftbColor;Brush.Color:=fBrushColor;//画矩形,应在DoDrawText()之后调用
  Brush.Style:=fBrushStyle;
  if tbLeft IN fBorderLine then begin MoveTo(P[0].x,P[0].y);LineTo(P[1].x,P[1].y);end;
  if tbRight IN fBorderLine then begin MoveTo(P[2].x,P[2].y);LineTo(P[3].x,P[3].y);end;
  if tbTop IN fBorderLine then begin MoveTo(P[0].x,P[0].y);LineTo(P[3].x,P[3].y);end;
  if tbBottom IN fBorderLine then begin MoveTo(P[2].x,P[2].y);LineTo(P[1].x,P[1].y);end;
  if akLeft IN Anchors2 then Rect.Right:=Rect.Left+fCx;
  if akRight IN Anchors2 then Rect.Left:=Rect.Right-fCx;
  if akTop IN Anchors2 then Rect.Bottom:=Rect.Top+fCy;
  if akBottom IN Anchors2 then Rect.Top:=Rect.Bottom-fCy;
  if ftx=txEllipse then Ellipse(Rect);
  if ftx=txRectangle then Rectangle(Rect);
  if ftx=txRoundRect then RoundRect(Rect.Left,Rect.Top,Rect.Right,Rect.Bottom,(Rect.Right-Rect.Left)div 4,(Rect.Bottom-Rect.Top)div 4);
  if ftx=txWjx then Wjx(Rect);
  Rect:=ClientRect;if ftx=txNorth then North(Rect);
  if ftx=txArrow then Arrow(Rect);
  if ftx=txCross then Cross(Rect);
  end;
end;

procedure TRotateLabel.Cross(aRect:TRect);//画十字架
var x,y,Cx,Cy,aAngle:integer;Lm:double;P:array[0..12] of TPoint;
Begin
 aAngle:=fEscapement;x:=0;y:=0;
 if  aAngle<=90  then begin { 1.Quadrant }//矩形框区域相对于(0,0)的起始坐标点
    x:=0;y:=Trunc(fCx*sin(aAngle*Pi/180));
 end else if aAngle<=180 then begin    { 2.Quadrant }
    x:=Trunc(fCx*-cos(aAngle*Pi/180));
    y:=Trunc(fCx*sin(aAngle*Pi/180)+fCy*cos((180-aAngle)*Pi/180));
 end else if aAngle<=270 then begin    { 3.Quadrant }
    x:=Trunc(fCx*-cos(aAngle*Pi/180)+fCy*sin((aAngle-180)*Pi/180));
    y:=Trunc(fCy*sin((270-aAngle)*Pi/180));
 end else if aAngle<=360 then begin { 4.Quadrant }
    x:=Trunc(fCy*sin((360-aAngle)*Pi/180));y:=0;
 end;//倾斜矩形框区域起始坐标点       倾斜矩形水平和垂直方向投影尺寸Cx、Cy
  Cx:=Abs(round(fcx*cos(aAngle*Pi/180)))+Abs(round(fcy*sin(aAngle*Pi/180)));
  Cy:=Abs(round(fcx*sin(aAngle*Pi/180)))+Abs(round(fcy*cos(aAngle*Pi/180)));
  if akLeft IN Anchors2 then aRect.Right:=aRect.Left+Cx;//根据投影尺寸进行靠边
  if akRight IN Anchors2 then aRect.Left:=aRect.Right-Cx;
  if akTop IN Anchors2 then aRect.Bottom:=aRect.Top+Cy;
  if akBottom IN Anchors2 then aRect.Top:=aRect.Bottom-Cy;
 P[0].Y:=aRect.Top+y;P[0].X:=aRect.Left+x;//倾斜矩形框靠边后的起始坐标点
 P[1].X:=P[0].X+round(fcy*sin(aAngle*Pi/180));//4点坐标逆时针顺序
 P[1].Y:=P[0].Y+round(fcy*cos(aAngle*Pi/180));
 P[2].X:=P[0].X+round(fcy*sin(aAngle*Pi/180)+fcx*cos(aAngle*Pi/180));
 P[2].Y:=P[0].Y+round(fcy*cos(aAngle*Pi/180)-fcx*sin(aAngle*Pi/180));
 P[3].X:=P[0].X+round(fcx*cos(aAngle*Pi/180));
 P[3].Y:=P[0].Y-round(fcx*sin(aAngle*Pi/180));//旋转矩形4点坐标
 Lm:=3/5;//各点坐标
 P[12].X:=Round((P[0].X+Lm*P[3].X)/(1+Lm));P[12].Y:=Round((P[0].Y+Lm*P[3].Y)/(1+Lm));
 Lm:=5/3;
 P[11].X:=Round((P[0].X+Lm*P[3].X)/(1+Lm));P[11].Y:=Round((P[0].Y+Lm*P[3].Y)/(1+Lm));
 Lm:=3/5;
 P[8].X:=Round((P[2].X+Lm*P[3].X)/(1+Lm));P[8].Y:=Round((P[2].Y+Lm*P[3].Y)/(1+Lm));
 Lm:=5/3;
 P[9].X:=Round((P[2].X+Lm*P[3].X)/(1+Lm));P[9].Y:=Round((P[2].Y+Lm*P[3].Y)/(1+Lm));
 Lm:=3/5;