dblocks.pas

来自「KSDev.BlockEngine.v3.03.rar 界面控件」· PAS 代码 · 共 74 行

unit dblocks;

{$I be_define.inc}

interface

uses Windows, Classes, Controls, Contnrs, Graphics, SysUtils, GdipObj,
  Gdipapi, GdipUtil, ddoc;

type

  NewRect = class(Block)
  private
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DrawBlock(G: TGPGraphics); override;
  published
  end;

implementation {===============================================================}

{ NewRect ========================================================================}

constructor NewRect.Create;
var
  P: BlockPoint;
begin
  inherited;
  { Snap }
  P := BlockPoint(Points.Add);
  P.Kind := pkSnapPoint;
  P.X := 0;
  P.Y := 0.5;
  P := BlockPoint(Points.Add);
  P.Kind := pkSnapPoint;
  P.X := 0.5;
  P.Y := 0;
  P := BlockPoint(Points.Add);
  P.Kind := pkSnapPoint;
  P.X := 1;
  P.Y := 0.5;
  P := BlockPoint(Points.Add);
  P.Kind := pkSnapPoint;
  P.X := 0.5;
  P.Y := 1;
  P := BlockPoint(Points.Add);
  P.Kind := pkBlockSnapPoint;
  P.X := 0.5;
  P.Y := 0.5;
end;

destructor NewRect.Destroy;
begin
  inherited;
end;

procedure NewRect.DrawBlock(G: TGPGraphics);
var
  P: TGPPen;
  B: TGPBrush;
begin
  P := Stroke.GetPen;
  B := Fill.GetBrush(PointXByName('lefttop'), PointYByName('lefttop'), PointXByName('rightbottom'), PointYByName('rightbottom'));
  G.FillRectangle(B, PointXByName('lefttop'), PointYByName('lefttop'), PointXByName('rightbottom') - PointXByName('lefttop'), PointYByName('rightbottom') - PointYByName('lefttop'));
  G.DrawRectangle(P, PointXByName('lefttop'), PointYByName('lefttop'), PointXByName('rightbottom') - PointXByName('lefttop'), PointYByName('rightbottom') - PointYByName('lefttop'));
  B.Free;
  P.Free;
end;

initialization
  RegisterClasses([NewRect]);
end.