ddoc.pas

KSDev.BlockEngine.v3.03.rar 界面控件

    property DesignState: DesignStates read FDesignState write SetDesignState;
    property EditMode: TEditMode read FEditMode write SetEditMode;
    property SnapToGrid: boolean read FSnapToGrid write SetSnapToGrid;
    property ShowSnapPoint: boolean read FShowSnapPoint write SetShowSnapPoint;
    property TextBlockLink: TextBlock read GetTextBlock;
    property Text: WideString read GetText write SetText;
  published
    property Align: BlockAlign read FBlockAlign write FBlockAlign;
    property BlockName: WideString read FBlockName write FBlockName;
    property Grouped: boolean read FGrouped write FGrouped;
    property Locked: boolean read FLocked write FLocked;
    property Fill: FillStyle read FFill write FFill;
    property Stroke: StrokeStyle read FStroke write FStroke;
    property Points: BlockPoints read FPoints write FPoints;
    property Angle: Float read FAngle write SetAngle;
    property Left: Float read FLeft write SetLeft;
    property Top: Float read FTop write SetTop;
    property Width: Float read FWidth write SetWidth;
    property Height: Float read FHeight write SetHeight;
    property Data: Cardinal read FData write FData;
  end;

  BlockClass = class of Block;

  TextAlignType = (
    TextAlignCenter,
    TextAlignFar,
    TextAlignNear
  );

  TextFontStyle = (
    TextFontStyleRegular,
    TextFontStyleBold,
    TextFontStyleItalic,
    TextFontStyleBoldItalic,
    TextFontStyleUnderline,
    TextFontStyleStrikeout
  );

  TextFontStyles = set of TextFontStyle;

  TextBlock = class(Block)
  private
    FText: WideString;
    FWordWrap: boolean;
    FTextAlign: TextAlignType;
    FVerticalTextAlign: TextAlignType;
    FFontFamily: string;
    FFontSize: Float;
    FPath: TGPGraphicsPath;
    FFontStyle: TextFontStyle;
    FFontStyles: TextFontStyles;
    procedure CreatePath; virtual;
    function GetTextBounds: FloatRect; virtual;
    function GetBounds: FloatRect; override;
    procedure SetFontFamily(const Value: string);
    procedure SetFontSize(const Value: Float);
    procedure SetText(const Value: WideString);
    procedure SetTextAlign(const Value: TextAlignType);
    procedure SetVerticalTextAlign(const Value: TextAlignType);
    procedure SetWordWrap(const Value: boolean);
    procedure SetFontStyle(const Value: TextFontStyle);
    procedure SetFontStyles(const Value: TextFontStyles);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DrawBlock(G: TGPGraphics); override;
    procedure CopyFrom(Source: Block); override;
    procedure AssignFromFont(AFont: TFont);
  published
    property Text: WideString read FText write SetText;
    property FontFamily: string read FFontFamily write SetFontFamily;
    property FontSize: Float read FFontSize write SetFontSize;
    property FontStyle: TextFontStyles read FFontStyles write SetFontStyles;
    property Style: TextFontStyle read FFontStyle write SetFontStyle stored false;
    property WordWrap: boolean read FWordWrap write SetWordWrap;
    property TextAlign: TextAlignType read FTextAlign write SetTextAlign;
    property VerticalTextAlign: TextAlignType read FVerticalTextAlign write SetVerticalTextAlign;
  end;

  StretchTextBlock = class(TextBlock)
  private
    procedure CreatePath; override;
    function GetTextBounds: FloatRect; override;
  public
    procedure DrawBlock(G: TGPGraphics); override;
  end;

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

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

  Ellipse = class(Block)
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
  published
    constructor Create(AOwner: TComponent); override;
  end;

  Line = class(Block)
  private
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
  published
    constructor Create(AOwner: TComponent); override;
  end;

  Line2 = class(Block)
  private
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
  published
    constructor Create(AOwner: TComponent); override;
  end;

  Arrow = class(Block)
  private
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
    procedure MovePoint(APoint: BlockPoint; X, Y: Float); override;
  published
    constructor Create(AOwner: TComponent); override;
  end;

  Polygon = class(Block)
  private
    procedure AddVertex(X, Y: Float);
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
  published
    constructor Create(AOwner: TComponent); override;
  end;

  Polyline = class(Block)
  private
    procedure AddVertex(X, Y: Float);
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
  published
    constructor Create(AOwner: TComponent); override;
  end;

  Spline = class(Block)
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
    procedure AddVertex(X, Y: Float);
  published
    constructor Create(AOwner: TComponent); override;
  end;

  FillSpline = class(Block)
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
    procedure AddVertex(X, Y: Float);
  published
    constructor Create(AOwner: TComponent); override;
  end;

  Bezier = class(Block)
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
    procedure AddVertex(X, Y: Float);
  published
    constructor Create(AOwner: TComponent); override;
  end;

  FillBezier = class(Block)
  public
    procedure DrawBlock(G: TGPGraphics); override;
    function PtOnBlock(X, Y: Float): boolean; override;
    procedure AddVertex(X, Y: Float);
  published
    constructor Create(AOwner: TComponent); override;
  end;

  Image = class(Block)
  private
    FBitmap: TGraphic;
    FB: array of TGPImage;
    FUndoLinkIndex: integer;
    procedure SetImage(const Value: TGraphic);
    function GetImage: TGraphic;
    function IsRealStream: Boolean;
    function IsUndoStream: Boolean;
    function GetUndoLink: string;
    procedure SetUndoLink(const Value: string);
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure DrawBlock(G: TGPGraphics); override;
  published
    property Image: TGraphic read GetImage write SetImage stored IsRealStream;
    property UndoLink: string read GetUndoLink write SetUndoLink stored IsUndoStream;
  end;

  TRepaintRectEvent = procedure (Sender: TObject; Left, Top, Right, Bottom: Float) of object;
  TSetCursorEvent = procedure (Sender: TObject; Cursor: TCursor) of object;
  TGetGraphicsEvent = procedure (Sender: TObject; var G: TGPGraphics) of object;
  TEditTextEvent = procedure (Sender: TObject; Block: TextBlock) of object;
  TEditImageEvent = procedure (Sender: TObject; Block: Image) of object;
  TChangeFocusEvent = procedure (Sender: TObject; ABlock: Block) of object;
  TNewBlockAddedEvent = procedure (Sender: TObject; ABlock: Block) of object;
  TDrawPointEvent = procedure (Sender: TObject; AGraphics: TGPGraphics; ABlock: Block; X, Y: Float; Point: BlockPoint; Redraw: boolean) of object;
  TGetPointRectEvent = procedure (Sender: TObject; ABlock: Block; Point: BlockPoint; var R: FloatRect) of object;
  TUndoSaveStateEvent = procedure (Sender: TObject) of object;
  TUndoEvent = procedure (Sender: TObject) of object;

  RootState = (
    rsSelecting,
    rsInserting
  );

  RootStates = set of RootState;

  ModeType = (
    mtSelect,
    mtInsertLine,
    mtInsertRect,
    mtInsertEllipse,
    mtInsertPolygon,
    mtInsertPolyline,
    mtInsertSpline,
    mtInsertFillSpline,
    mtInsertBezier,
    mtInsertFillBezier,
    mtInsertBlockClass,
    mtInsertSnapPoint,
    mtInsertRoundRect,
    mtInsertText,
    mtInsertImage,
    mtInsertStretchText
  );

  Root = class(Block)
  private
    FOnRepaint: TNotifyEvent;
    FOnRepaintRect: TRepaintRectEvent;
    FOnSetCursor: TSetCursorEvent;
    FOnGetGraphics: TGetGraphicsEvent;
    FModeType: ModeType;
    FInsertBlockClass: BlockClass;
    FStartPos: FloatPoint;
    FState: RootStates;
    FOnEditText: TEditTextEvent;
    FPolygonPts: array of FloatPoint;
    FPolygonRect: FloatRect;
    FMoveBlock: Block;
    FOnEditImage: TEditImageEvent;
    FOnChangeFocus: TChangeFocusEvent;
    FOnBlockAddedEvent: TNewBlockAddedEvent;
    FOnBlockInsertEvent: TNewBlockAddedEvent;
    FOnDrawPoint: TDrawPointEvent;
    FOnGetPointRectEvent: TGetPointRectEvent;
    FOnUndo: TUndoEvent;
    FOnUndoSaveState: TUndoSaveStateEvent;
    FBackBlock: Block;
  protected
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Draw(G: TGPGraphics); override;
    function PerformNotification(Event: DesignEvent; Sender: Block; Data: array of Float): TNotificationResult; override;
    function HandleNotification(Event: DesignEvent; Sender: Block; Data: array of Float): TNotificationResult; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Float); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Float); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Float); override;
    procedure AddBlock(ABlock: Block); override;
    { edit settings }
    property Mode: ModeType read FModeType write FModeType;
    property State: RootStates read FState write FState;
    property InsertBlockClass: BlockClass read FInsertBlockClass write FInsertBlockClass;
    property BackBlock: Block read FBackBlock write FBackBlock;
    { events }
    property OnRepaint: TNotifyEvent read FOnRepaint write FOnRepaint;
    property OnRepaintRect: TRepaintRectEvent read FOnRepaintRect write FOnRepaintRect;
    property OnSetCursor: TSetCursorEvent read FOnSetCursor write FOnSetCursor;
    property OnGetGraphics: TGetGraphicsEvent read FOnGetGraphics write FOnGetGraphics;
    property OnEditText: TEditTextEvent read FOnEditText write FOnEditText;
    property OnEditImage: TEditImageEvent read FOnEditImage write FOnEditImage;
    property OnChangeFocus: TChangeFocusEvent read FOnChangeFocus write FOnChangeFocus;
    property OnBlockAddedEvent: TNewBlockAddedEvent read FOnBlockAddedEvent
      write FOnBlockAddedEvent;
    property OnBlockInsertEvent: TNewBlockAddedEvent read FOnBlockInsertEvent
      write FOnBlockInsertEvent;
    property OnDrawPoint: TDrawPointEvent read FOnDrawPoint write FOnDrawPoint;
    property OnGetPointRectEvent: TGetPointRectEvent read FOnGetPointRectEvent
      write FOnGetPointRectEvent;
    property OnUndoSaveState: TUndoSaveStateEvent read FOnUndoSaveState
      write FOnUndoSaveState;
    property OnUndo: TUndoEvent read FOnUndo write FOnUndo;
  end;

  PaperKind = (
    A1,
    A2,
    A3,
    A4,
    Custom
  );

  PaperOrientation = (
    Portrait,
    Landscape
  );

  PaperOptions = class(TPersistent)
  private
    FHeight: Float;
    FWidth: Float;
    FKind: PaperKind;
    FOrientation: PaperOrientation;
    procedure SetHeight(const Value: Float);
    procedure SetKind(const Value: PaperKind);
    procedure SetWidth(const Value: Float);
    procedure SetOrientation(const Value: PaperOrientation);
  public
    constructor Create; virtual;
    procedure ChangeUnit(SrcUnit, DstUnit: UnitType);
  published
    property Kind: PaperKind read FKind write SetKind;
    property Orientation: PaperOrientation read FOrientation
      write SetOrientation;
    property Width: Float read FWidth write SetWidth;
    property Height: Float read FHeight write SetHeight;
  end;

  BlockDocument = class(TComponent)
  private
    FRoot: Root;
    FUnitType: UnitType;
    FPaper: PaperOptions;
    procedure SetUnitType(const Value: UnitType);
  protected
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { objects }
    procedure Clear;
    procedure SaveToTextFile(AFileName: string);
    procedure LoadFromTextFile(AFileName: string);
    procedure SaveToBinFile(AFileName: string);
    procedure LoadFromBinFile(AFileName: string);
    procedure SaveToStream(AStream: TStream);
    procedure LoadFromStream(AStream: TStream);
    { shapes }
    procedure GroupSelected;
    procedure AddBlock(ABlock: Block);
    function AddFromTextFile(AFileName: string): Block;
    function AddFromBinFile(AFileName: string): Block;
    { drawing }
    procedure Draw(G: TGPGraphics);
    { props }
    property BlockRoot: Root read FRoot write FRoot;
  published
    property UnitType: UnitType read FUnitType write SetUnitType;
    property Paper: PaperOptions read FPaper write FPaper;
  end;

var
  DevicePixel: Float; { size of the device pixel in current unit }
  GridSize: Float = 0;

function UnitTypeToGPUnit(AUnit: UnitType): TUnit;
function ConvertValue(SrcUnit: UnitType; SrcValue: Float;
  DstUnit: UnitType): Float;

function MakeFloatRect(L, T, R, B: Float): FloatRect;
function MakeFloatRect2(L, T, Width, Height: Float): FloatRect;
function RectByPoint(X1, Y1, X2, Y2: Float): FloatRect;
function GPRectByPoint(X1, Y1, X2, Y2: Float): TGPRectF;
function RectByBlock(ABlock: Block): FloatRect;
function GPRectByBlock(ABlock: Block): TGPRectF;
function RectByPoints(Pts: array of FloatPoint): FloatRect;
function GPRectByPoints(Pts: array of FloatPoint): TGPRectF;

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

uses ddocstore;

var
  UndoImages: TList;

function UnitTypeToGPUnit(AUnit: UnitType): TUnit;
begin
  case AUnit of
    Inch: Result := UnitInch;
    Pt: Result := UnitPoint;
    Pixel: Result := UnitDisplay;
    Millimeter, Centimeter: Result := UnitMillimeter;
  else
    Result := UnitInch;
  end;
end;

function ConvertValue(SrcUnit: UnitType; SrcValue: Float;
  DstUnit: UnitType): Float;
var
  SrcG, DstG: TGPGraphics;
  P: TGPPointF;
  SrcB: TBitmap;
  DstB: TBitmap;
begin
  SrcB := TBitmap.Create;
  SrcB.Width := 10; SrcB.Height := 10;
  DstB := TBitmap.Create;
  DstB.Width := 10; DstB.Height := 10;

  SrcG := TGPGraphics.Create(SrcB.Canvas.Handle, 0, 0);
  DstG := TGPGraphics.Create(DstB.Canvas.Handle, 0, 0);
  try
    SrcG.SetPageUnit(UnitTypeToGPUnit(SrcUnit));
    DstG.SetPageUnit(UnitTypeToGPUnit(DstUnit));

    { Transform to world }
    P.X := SrcValue;
    P.Y := SrcValue;
    SrcG.TransformPoints(CoordinateSpaceDevice, CoordinateSpacePage, PGPPointF(@P), 1);
    { Transform to dest }
    DstG.TransformPoints(CoordinateSpacePage, CoordinateSpaceDevice, PGPPointF(@P), 1);
    { }
    Result := P.X;
  finally
    SrcG.Free;
    DstG.Free;
  end;
  SrcB.Free;
  DstB.Free;
end;

function MakeFloatRect(L, T, R, B: Float): FloatRect;
begin
  Result.Left := L;
  Result.Top := T;
  Result.Right := R;
  Result.Bottom := B;
end;

function MakeFloatRect2(L, T, Width, Height: Float): FloatRect;
begin
  Result.Left := L;
  Result.Top := T;
  Result.Right := L + Width;
  Result.Bottom := T + Height;
end;