rm_rrect.pas

report machine 2.3 功能强大

{*****************************************************}
{                                                     }
{               Report Machine v2.0                   }
{          RoundRect plus Add-in object               }
{                                                     }
{*****************************************************}

unit RM_rrect;

interface

{$I RM.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  RM_Class, StdCtrls, ExtCtrls, ClipBrd{$IFDEF Delphi4}, ImgList{$ENDIF}
{$IFDEF Delphi6}, Variants{$ENDIF};

const
  SRrectType = 'Vertical,Horizontal,Elliptic,Rectangle,Horiz._Center,Vert._Center';

type
  {These are the six different gradient styles available.}
  TRMGradientStyle = (gsHorizontal, gsVertical, gsElliptic, gsRectangle,
    gsVertCenter, gsHorizCenter);

  TRMRoundRectObject = class(TComponent) // fake component
  end;

  TRMRoundRect = packed record
    SdColor: TColor; // Color of Shadow
    wShadow: Integer; // Width of shadow
    Cadre: Boolean; // Frame On/Off
    sCurve: Boolean; // RoundRect On/Off
    wCurve: Integer; // Curve size
  end;

  { TRMRoundRectView }
  TRMRoundRectView = class(TRMMemoView)
  private
  protected
    procedure SetPropValue(Index: string; Value: Variant); override;
    function GetPropValue(Index: string): Variant; override;
  public
    Cadre: TRMRoundRect;
    constructor Create; override;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    procedure CalcGaps; override;
    procedure ShowFrame; override;
    procedure ShowBackGround; override;
    procedure DefineProperties; override;
    procedure ShowEditor; override;
  end;

  { TRMRoundRectForm }
  TRMRoundRectForm = class(TForm)
    M1: TMemo;
    btnExpr: TButton;
    lblSample: TLabel;
    colorDlg: TColorDialog;
    bOk: TButton;
    bCancel: TButton;
    imgSample: TImage;
    cbGradian: TCheckBox;
    panCurve: TPanel;
    cmShadow: TCheckBox;
    sCurve: TEdit;
    lblSWidth: TLabel;
    ShWidth: TEdit;
    lblSColor: TLabel;
    bcolor: TImage;
    cbCadre: TCheckBox;
    panGrad: TPanel;
    Label1: TLabel;
    bcolor3: TImage;
    Label2: TLabel;
    bColor2: TImage;
    cbStyle: TComboBox;
    Label3: TLabel;
    procedure btnExprClick(Sender: TObject);
    procedure bColorClick(Sender: TObject);
    procedure ShWidthChange(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure cbCadreClick(Sender: TObject);
    procedure cmShadowClick(Sender: TObject);
    procedure M1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure cbGradianClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    FView: TRMRoundRectView;
    ShadowColor: TColor;
    NormalColor: TColor;
    procedure ChgColorButton(S: TObject; C: TColor);
    procedure UpdateSample;
    procedure Localize;
  public
  end;

implementation

uses RM_Const, RM_Utils, RM_CmpReg;

{$R *.DFM}

procedure PaintGrad(Cv: TCanvas; X, Y, X1, Y1: Word;
  FBeginClr, FEndClr: TColor; FGradientStyle: TRMGradientStyle);
var
  FromR, FromG, FromB: Integer;
  DiffR, DiffG, DiffB: Integer;
  ox, oy, dx, dy: Integer;

  procedure DoHorizontal(fr, fg, fb, dr, dg, db: Integer);
  var
    ColorRect: TRect;
    I: Integer;
    R, G, B: Byte;
  begin
    ColorRect.Top := oy;
    ColorRect.Bottom := oy + dy;
    for I := 0 to 255 do
    begin
      ColorRect.Left := MulDiv(I, dx, 256) + ox;
      ColorRect.Right := MulDiv(I + 1, dx, 256) + ox;
      R := fr + MulDiv(I, dr, 255);
      G := fg + MulDiv(I, dg, 255);
      B := fb + MulDiv(I, db, 255);
      Cv.Brush.Color := RGB(R, G, B);
      Cv.FillRect(ColorRect);
    end;
  end;

  procedure DoVertical(fr, fg, fb, dr, dg, db: Integer);
  var
    ColorRect: TRect;
    I: Integer;
    R, G, B: Byte;
  begin
    ColorRect.Left := ox;
    ColorRect.Right := ox + dx;
    for I := 0 to 255 do
    begin
      ColorRect.Top := MulDiv(I, dy, 256) + oy;
      ColorRect.Bottom := MulDiv(I + 1, dy, 256) + oy;
      R := fr + MulDiv(I, dr, 255);
      G := fg + MulDiv(I, dg, 255);
      B := fb + MulDiv(I, db, 255);
      Cv.Brush.Color := RGB(R, G, B);
      Cv.FillRect(ColorRect);
    end;
  end;

  procedure DoElliptic(fr, fg, fb, dr, dg, db: Integer);
  var
    I: Integer;
    R, G, B: Byte;
    Pw, Ph: Double;
    x1, y1, x2, y2: Double;
    h, oldh: HRGN;
  begin
    Cv.Pen.Style := psClear;
    Cv.Pen.Mode := pmCopy;
    h := CreateRectRgn(ox, oy, ox + dx, oy + dy);
    oldh := SelectObject(Cv.Handle, h);

    x1 := 0 - (dx / 4) + ox;
    x2 := dx + (dx / 4) + ox;
    y1 := 0 - (dy / 4) + oy;
    y2 := dy + (dy / 4) + oy;
    Pw := ((dx / 4) + (dx / 2)) / 155;
    Ph := ((dy / 4) + (dy / 2)) / 155;
    for I := 0 to 155 do
    begin
      x1 := x1 + Pw;
      x2 := X2 - Pw;
      y1 := y1 + Ph;
      y2 := y2 - Ph;
      R := fr + MulDiv(I, dr, 155);
      G := fg + MulDiv(I, dg, 155);
      B := fb + MulDiv(I, db, 155);
      Cv.Brush.Color := R or (G shl 8) or (b shl 16);
      Cv.Ellipse(Trunc(x1), Trunc(y1), Trunc(x2), Trunc(y2));
    end;
    Cv.Pen.Style := psSolid;
    SelectObject(Cv.Handle, oldh);
    DeleteObject(h);
  end;

  procedure DoRectangle(fr, fg, fb, dr, dg, db: Integer);
  var
    I: Integer;
    R, G, B: Byte;
    Pw, Ph: Real;
    x1, y1, x2, y2: Double;
  begin
    Cv.Pen.Style := psClear;
    Cv.Pen.Mode := pmCopy;
    x1 := 0 + ox;
    x2 := ox + dx;
    y1 := 0 + oy;
    y2 := oy + dy;
    Pw := (dx / 2) / 255;
    Ph := (dy / 2) / 255;
    for I := 0 to 255 do
    begin
      x1 := x1 + Pw;
      x2 := X2 - Pw;
      y1 := y1 + Ph;
      y2 := y2 - Ph;
      R := fr + MulDiv(I, dr, 255);
      G := fg + MulDiv(I, dg, 255);
      B := fb + MulDiv(I, db, 255);
      Cv.Brush.Color := RGB(R, G, B);
      Cv.FillRect(Rect(Trunc(x1), Trunc(y1), Trunc(x2), Trunc(y2)));
    end;
    Cv.Pen.Style := psSolid;
  end;

  procedure DoVertCenter(fr, fg, fb, dr, dg, db: Integer);
  var
    ColorRect: TRect;
    I: Integer;
    R, G, B: Byte;
    Haf: Integer;
  begin
    Haf := dy div 2;
    ColorRect.Left := 0 + ox;
    ColorRect.Right := ox + dx;
    for I := 0 to Haf do
    begin
      ColorRect.Top := MulDiv(I, Haf, Haf) + oy;
      ColorRect.Bottom := MulDiv(I + 1, Haf, Haf) + oy;
      R := fr + MulDiv(I, dr, Haf);
      G := fg + MulDiv(I, dg, Haf);
      B := fb + MulDiv(I, db, Haf);
      Cv.Brush.Color := RGB(R, G, B);
      Cv.FillRect(ColorRect);
      ColorRect.Top := dy - (MulDiv(I, Haf, Haf)) + oy;
      ColorRect.Bottom := dy - (MulDiv(I + 1, Haf, Haf)) + oy;
      Cv.FillRect(ColorRect);
    end;
  end;

  procedure DoHorizCenter(fr, fg, fb, dr, dg, db: Integer);
  var
    ColorRect: TRect;
    I: Integer;
    R, G, B: Byte;
    Haf: Integer;
  begin
    Haf := dx div 2;
    ColorRect.Top := 0 + oy;
    ColorRect.Bottom := oy + dy;
    for I := 0 to Haf do
    begin
      ColorRect.Left := MulDiv(I, Haf, Haf) + ox;
      ColorRect.Right := MulDiv(I + 1, Haf, Haf) + ox;
      R := fr + MulDiv(I, dr, Haf);
      G := fg + MulDiv(I, dg, Haf);
      B := fb + MulDiv(I, db, Haf);
      Cv.Brush.Color := RGB(R, G, B);
      Cv.FillRect(ColorRect);
      ColorRect.Left := dx - (MulDiv(I, Haf, Haf)) + ox;
      ColorRect.Right := dx - (MulDiv(I + 1, Haf, Haf)) + ox;
      Cv.FillRect(ColorRect);
    end;
  end;

begin
  if Cv = nil then Exit;
  ox := X;
  oy := Y;
  dx := X1 - X;
  dy := Y1 - Y;
  FromR := FBeginClr and $000000FF;
  FromG := (FBeginClr shr 8) and $000000FF;
  FromB := (FBeginClr shr 16) and $000000FF;
  DiffR := (FEndClr and $000000FF) - FromR;
  DiffG := ((FEndClr shr 8) and $000000FF) - FromG;
  DiffB := ((FEndClr shr 16) and $000000FF) - FromB;
  if FGradientStyle = gsHorizontal then
    DoHorizontal(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  if FGradientStyle = gsVertical then
    DoVertical(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  if FGradientStyle = gsElliptic then
    DoElliptic(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  if FGradientStyle = gsRectangle then
    DoRectangle(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  if FGradientStyle = gsVertCenter then
    DoVertCenter(FromR, FromG, FromB, DiffR, DiffG, DiffB);
  if FGradientStyle = gsHorizCenter then
    DoHorizCenter(FromR, FromG, FromB, DiffR, DiffG, DiffB);
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMRoundRectView}

constructor TRMRoundRectView.Create;
begin
  inherited Create;
  BaseName := 'RoundRect';

  Cadre.SdColor := clGray;
  Cadre.wShadow := 6;
  Cadre.Cadre := True;
  Cadre.sCurve := True;
  Cadre.wCurve := 10;

  RMConsts['gsVertical'] := gsVertical;
  RMConsts['gsHorizontal'] := gsHorizontal;
  RMConsts['gsElliptic'] := gsElliptic;
  RMConsts['gsRectangle'] := gsRectangle;
  RMConsts['gsHorizCenter'] := gsHorizCenter;
  RMConsts['gsVertCenter'] := gsVertCenter;
end;

procedure TRMRoundRectView.DefineProperties;
begin
  inherited DefineProperties;
  AddProperty('ShadowColor', [RMdtColor], nil);
  AddProperty('ShadowWidth', [RMdtInteger], nil);
  AddProperty('RoundRect', [RMdtBoolean], nil);
  AddProperty('RoundSize', [RMdtInteger], nil);
  AddProperty('Gradient', [RMdtBoolean], nil);
  AddEnumProperty('Style',
    'gsVertical;gsHorizontal;gsElliptic;gsRectangle;gsHorizCenter;gsVertCenter',
    [gsVertical, gsHorizontal, gsElliptic, gsRectangle, gsHorizCenter, gsVertCenter]);
  AddProperty('BeginColor', [RMdtColor], nil);
  AddProperty('EndColor', [RMdtColor], nil);
end;

procedure TRMRoundRectView.SetPropValue(Index: string; Value: Variant);
begin
  inherited SetPropValue(Index, Value);
  Index := AnsiUpperCase(Index);
  with Cadre do
  begin
    if Index = 'SHADOWCOLOR' then
      SdColor := Value
    else if Index = 'SHADOWWIDTH' then
      wShadow := Value
    else if Index = 'ROUNDRECT' then
      sCurve := Value
    else if Index = 'ROUNDSIZE' then
      wCurve := Value
    else if Index = 'GRADIENT' then
    begin
      if Boolean(Value) then
        wShadow := -99
      else
        wShadow := 10;
    end
    else if Index = 'STYLE' then
      wCurve := Value
    else if Index = 'BEGINCOLOR' then
      SdColor := Value
    else if Index = 'ENDCOLOR' then
      FillColor := Value;
  end;
end;

function TRMRoundRectView.GetPropValue(Index: string): Variant;
begin
  Index := AnsiUpperCase(Index);
  Result := inherited GetPropValue(Index);
  if Result <> Null then Exit;
  with Cadre do
  begin
    if Index = 'SHADOWCOLOR' then
      Result := SdColor
    else if Index = 'SHADOWWIDTH' then
      Result := wShadow
    else if Index = 'ROUNDRECT' then
      Result := sCurve
    else if Index = 'ROUNDSIZE' then
      Result := wCurve
    else if Index = 'GRADIENT' then
      Result := wShadow = -99
    else if Index = 'STYLE' then
    begin
      if wShadow = -99 then
        Result := wCurve
      else
        Result := 0;
    end
    else if Index = 'BEGINCOLOR' then
      Result := SdColor
    else if Index = 'ENDCOLOR' then
      Result := FillColor;
  end;
end;

procedure TRMRoundRectView.LoadFromStream(Stream: TStream);
begin
  inherited LoadFromStream(Stream);
  Stream.Read(Cadre, SizeOf(Cadre));
end;

procedure TRMRoundRectView.SaveToStream(Stream: TStream);
begin
  LVersion := 0;
  inherited SaveToStream(Stream);
  Stream.Write(Cadre, SizeOf(Cadre));