dviewer.pas

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

unit dviewer;

{$I be_define.inc}
{$I dviewer.inc}

interface

uses Windows, Messages, Classes, SysUtils, Controls, Graphics, Forms,
  GdipObj, Gdipapi, GdipUtil, ddoc, dblocks, bever;

const

  DefaultGridSize  = 0.05;
  RulerSize        = 20;
  RulerMargin      = 3;
  OneUnitTics      = 50; // in pixel

  MaxScroll        = $FFFFFF;
  PageScroll       = $FFFF;

  WM_REPAINT       = WM_USER + 1345;


type

  TGridKind = (
    gkAuto,
    gkFixed
  );

  TViewKind = (
    vkPage,
    vkBlank
  );

  TBlockOnPaint = procedure (Sender: TObject; Graphic: TGPGraphics; ARect: FloatRect) of object;

  TBlockViewer = class(TCustomControl)
  private
    FBlockDocument: BlockDocument;
    FScale: single;
    FShowGrid: boolean;
    FGridKind: TGridKind;
    FGridHSize: Float;
    FGridVSize: Float;
    FShowRulers: boolean;
    FMousePos: TPoint;
    FSmooth: boolean;
    FViewKind: TViewKind;
    FHScrollbar: boolean;
    FVScrollbar: boolean;
    FOnPaint: TBlockOnPaint;
    procedure SetScale(const Value: single);
    procedure SetShowGrid(const Value: boolean);
    procedure SetGridKind(const Value: TGridKind);
    procedure SetGridHSize(const Value: Float);
    procedure SetGridVSize(const Value: Float);
    procedure SetShowRulers(const Value: boolean);
    procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
    procedure WMMouseWheel(var Msg: TWMMouseWheel); message WM_MOUSEWHEEL;
    procedure SetSmooth(const Value: boolean);
    procedure SetViewKind(const Value: TViewKind);
    function GetOrientation: PaperOrientation;
    function GetPaperKind: PaperKind;
    procedure SetOrientation(const Value: PaperOrientation);
    procedure SetPaperKind(const Value: PaperKind);
    procedure SetBackgroundBlock(const Value: Block);
    function GetBackgroundBlock: Block;
    procedure SetHScrollBar(const Value: boolean);
    procedure SetVScrollBar(const Value: boolean);
  protected
    Scene: TBitmap;
    WorkWidth, WorkHeight: Float;
    PageX, PageY: Float;
    PageWidth, PageHeight: Float;
    ViewWidth, ViewHeight: Float;
    ViewX, ViewY: Float;
    FUnitType: UnitType;
    TicsStep: Float;
    Graphics: TGPGraphics;
    Clipped: boolean;
    ClipRgn: TGPRegion;
    FDisableUpdate: boolean;
    procedure SetGraphics;
    procedure SetBlockDocument(const Value: BlockDocument); virtual;
    procedure SetUnitType(const Value: UnitType); virtual;

    procedure WMRepaint(var Msg: TMessage); message WM_REPAINT;
    procedure Paint; override;
    procedure PaintPaper; virtual;
    procedure PaintBlockDocument; virtual;
    procedure PaintRulers;
    procedure UpdateBlockDocument; virtual;
    procedure UpdateBlockDocumentRect(Left, Top, Right, Bottom: Float); virtual;
    procedure UpdateSceneRect(Left, Top, Right, Bottom: Float); virtual;
    procedure DoRepaintEvent(Sender: TObject);
    procedure DoRepaintRectEvent(Sender: TObject; Left, Top, Right, Bottom: Float);
    procedure DoGetGraphics(Sender: TObject; var G: TGPGraphics);
    { Scroll }
    procedure Scroll(Dx, Dy: integer);
    procedure ScrollTo(X, Y: integer);
    { Mouse }
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    { VCL }
    procedure CreateHandle; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Resize; override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UpdateScrollBars;
    procedure UpdateAll;
    function FindBlockByName(AName: WideString): Block;
    function PaperToScreen(X, Y: Float): TPoint;
    function ScreenToPaper(X, Y: integer): FloatPoint;
    function GetRealValue(APixelValue: integer): single;
    function GetPixelValue(ARealValue: single): integer;
    procedure PaintBlockDocumentToCanvas(Canvas: TCanvas);
    procedure LoadFromStream(AStream: TStream); virtual;
    procedure LoadFromTextFile(AFileName: string); virtual;
    procedure LoadFromFile(AFileName: string); virtual;
    procedure SaveToStream(AStream: TStream); virtual;
    procedure SaveToTextFile(AFileName: string); virtual;
    procedure SaveToFile(AFileName: string); virtual;
    procedure SetDocumentCopy(ADoc: BlockDocument);
    property Document: BlockDocument read FBlockDocument write SetBlockDocument;
    property BackgroundBlock: Block read GetBackgroundBlock write SetBackgroundBlock;
  published
    property Align;
    property BiDiMode;
    { D4U }
    property Anchors;
    property Constraints;
    property DockOrientation default doNoOrient;
    property Floating;
    property BevelKind;
    property DoubleBuffered;
    property DragKind;
    { }
    property Cursor;
    property Scale: single read FScale write SetScale;
    property GridKind: TGridKind read FGridKind write SetGridKind;
    property GridVSize: Float read FGridVSize write SetGridVSize;
    property GridHSize: Float read FGridHSize write SetGridHSize;
    property ShowGrid: boolean read FShowGrid write SetShowGrid;
    property ShowRulers: boolean read FShowRulers write SetShowRulers;
    property ViewKind: TViewKind read FViewKind write SetViewKind;
    property UnitType: UnitType read FUnitType write SetUnitType;
    property Paper: PaperKind read GetPaperKind write SetPaperKind;
    property Orientation: PaperOrientation read GetOrientation
      write SetOrientation;
    property Smooth: boolean read FSmooth write SetSmooth;
    property HorzScrollBar: boolean read FHScrollbar write SetHScrollBar;
    property VertScrollBar: boolean read FVScrollbar write SetVScrollBar;
    property OnClick;
    property OnEnter;
    property OnExit;
    property OnDragDrop;
    property OnDragOver;
    property OnStartDrag;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnDblClick;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnPaint: TBlockOnPaint read FOnPaint write FOnPaint;
  end;

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

{ TBlockViewer ====================================================================}

constructor TBlockViewer.Create(AOwner: TComponent);
begin
  inherited;
  Scene := TBitmap.Create;
  Scene.HandleType := bmDIB;

  FVScrollbar := true;
  FHScrollbar := true;

  Color := clAppWorkspace;
  FScale := 1;
  FShowRulers := true;
  FGridVSize := DefaultGridSize;
  FGridHSize := DefaultGridSize;
  FSmooth := true;
  Color := clAppWorkspace;
  TabStop := true;

  Document := BlockDocument.Create(nil);

  Width := 100;
  Height := 100;
end;

destructor TBlockViewer.Destroy;
begin
  FBlockDocument.Free;
  FBlockDocument := nil;
  if Graphics <> nil then FreeAndNil(Graphics);
  Scene.Free;
  inherited;
end;

procedure TBlockViewer.Loaded;
begin
  inherited;
  if csDesigning in ComponentState then
    UpdateAll;
end;

procedure TBlockViewer.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style or WS_VSCROLL or WS_HSCROLL;
end;

procedure TBlockViewer.CreateHandle;
begin
  inherited;
  SetGraphics;
  case FViewKind of
    vkPage:
      begin
        ViewX := PageX;
        ViewY := PageY;
      end;
    vkBlank:
      begin
        ViewX := 0;
        ViewY := 0;
      end;
  end;
  UpdateScrollBars;
end;

procedure TBlockViewer.SetGraphics;
begin
  if not HandleAllocated then Exit;
  if FDisableUpdate then Exit;

  { Set scene vars }
  if Document <> nil then
  begin
    case FViewKind of
      vkPage:
        begin
          WorkWidth := Document.Paper.Width * 3;
          WorkHeight := Document.Paper.Height * 3;
          PageWidth := Document.Paper.Width;
          PageHeight := Document.Paper.Height;
          PageX := PageWidth;
          PageY := PageHeight;
        end;
      vkBlank:
        begin
          WorkWidth := Document.Paper.Width;
          WorkHeight := Document.Paper.Height;
          PageWidth := Document.Paper.Width;
          PageHeight := Document.Paper.Height;
          PageX := 0;
          PageY := 0;
        end;
    end;
    if FShowRulers then
    begin
      ViewWidth := GetRealValue(ClientWidth - RulerSize);
      ViewHeight := GetRealValue(ClientHeight - RulerSize);
    end
    else
    begin
      ViewWidth := GetRealValue(ClientWidth);
      ViewHeight := GetRealValue(ClientHeight);
    end;
    if WorkWidth < ViewWidth then WorkWidth := ViewWidth;
    if WorkHeight < ViewHeight then WorkHeight := ViewHeight;
  end;

  if Graphics <> nil then FreeAndNil(Graphics);
  Graphics := TGPGraphics.Create(Scene.Canvas.Handle, 0, 0);
  with Graphics do
  begin
    ResetTransform;
    if Document <> nil then
      SetPageUnit(UnitTypeToGPUnit(Document.UnitType));
    SetPageScale(FScale);
    { Set view transform }
    if Document <> nil then
    begin
      if FShowRulers then
        TranslateTransform(-ViewX + GetRealValue(RulerSize), -ViewY + GetRealValue(RulerSize))
      else
        TranslateTransform(-ViewX, -ViewY)
    end;
    DevicePixel := GetRealValue(1);
  end;
end;

function TBlockViewer.PaperToScreen(X, Y: Float): TPoint;
var
  P: TGPPointF;
begin
  if Graphics <> nil then
  begin
    if Document <> nil then
    begin
      if FShowRulers then
      begin
        P.X := X + PageX - ViewX + GetRealValue(RulerSize);
        P.Y := Y + PageY - ViewY + GetRealValue(RulerSize);
      end
      else
      begin
        P.X := X + PageX - ViewX;
        P.Y := Y + PageY - ViewY;
      end;
    end;
    Graphics.TransformPoints(CoordinateSpaceDevice, CoordinateSpacePage, PGPPointF(@P), 1);
    Result := Point(Round(P.X), Round(P.Y));
  end
  else
    Result := Point(0, 0);
end;

function TBlockViewer.ScreenToPaper(X, Y: integer): FloatPoint;
var
  P: TGPPointF;
begin
  Result.X := 0;
  Result.Y := 0;
  if Graphics <> nil then
  begin
    P.X := X;
    P.Y := Y;

    Graphics.TransformPoints(CoordinateSpacePage, CoordinateSpaceDevice, PGPPointF(@P), 1);

    if FShowRulers then
    begin
      P.X := P.X - PageX + ViewX - GetRealValue(RulerSize);
      P.Y := P.Y - PageY + ViewY - GetRealValue(RulerSize);
    end
    else
    begin
      P.X := P.X - PageX + ViewX;
      P.Y := P.Y - PageY + ViewY;
    end;

    Result := P;
  end;
end;

function TBlockViewer.GetRealValue(APixelValue: integer): single;
var
  P: TGPPointF;
begin
  if Graphics <> nil then
  begin
    P.X := APixelValue;
    P.Y := APixelValue;
    Graphics.TransformPoints(CoordinateSpacePage, CoordinateSpaceDevice, PGPPointF(@P), 1);
    Result := P.X;
  end
  else
    Result := 0;
end;

function TBlockViewer.GetPixelValue(ARealValue: single): integer;
var
  P: TGPPointF;
begin
  if Graphics <> nil then
  begin
    P.X := ARealValue;
    P.Y := ARealValue;
    Graphics.TransformPoints(CoordinateSpaceDevice, CoordinateSpacePage, PGPPointF(@P), 1);
    Result := Round(P.X);
  end
  else
    Result := 0;
end;

procedure TBlockViewer.Paint;
begin
  if FDisableUpdate then Exit;
  
  if Document = nil then
  begin
    Canvas.Brush.Color := Color;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(ClientRect);
  end
  else
  begin
    PaintRulers;
    PaintPaper;
    { Draw scene }
    if FShowRulers then
    begin
      BitBlt(Canvas.Handle, RulerSize, RulerSize, ClientWidth - RulerSize,
        ClientHeight - RulerSize, Scene.Canvas.Handle, RulerSize, RulerSize,
        SRCCOPY);
    end
    else
      Canvas.Draw(0, 0, Scene);
  end;
end;

procedure TBlockViewer.PaintRulers;
var
  R: TRect;
  Pt: TPoint;
  Tics: Float;
  Buffer: TBitmap;
begin
  if Graphics = nil then Exit;
  if Document = nil then Exit;
  if FDisableUpdate then Exit;

  { Calc TipcStep }
  TicsStep := 1;
  while (GetPixelValue(TicsStep) < OneUnitTics) do
    TicsStep := TicsStep + 1;
  if (TicsStep > 10) then
    TicsStep := Trunc(TicsStep / 10) * 10;
  if (Document <> nil) and (Document.UnitType = Centimeter) then
    if TicsStep < 10 then
      TicsStep := 10;

  if not FShowRulers then Exit;

  ExcludeClipRect(Canvas.Handle, 0, 0, RulerSize, RulerSize);

  Buffer := TBitmap.Create;
  try
    { Horizontal }
    Buffer.Width := ClientWidth;
    Buffer.Height := RulerSize;
    with Buffer.Canvas do
    begin
      R := Classes.Rect(0, 0, Buffer.Width, Buffer.Height);
      Brush.Style := bsSolid;
      Brush.Color := clBtnFace;
      FillRect(R);
      if Document <> nil then
      begin
        { Calc rulers vars }
        InflateRect(R, -RulerMargin, -RulerMargin);
        with Document.Paper do
        begin
          Pt := PaperToScreen(0, 0);
          R.Left := Pt.X;
          Pt := PaperToScreen(PageWidth, PageHeight);
          R.Right := Pt.X;
        end;
        Brush.Color := clWindow;
        FillRect(R);

        { Draw tics }
        Pen.Color := clBlack;
        Tics := - Trunc(PageX / TicsStep) * TicsStep;
        { Set font }
        Brush.Style := bsClear;
        Font.Name := 'Arial';
        Font.Size := 6;
        while Tics < WorkWidth do
        begin
          { Draw big tic }
          Pt := PaperToScreen(Tics, 0);
          MoveTo(Pt.X, RulerMargin);
          LineTo(Pt.X, RulerSize - RulerMargin);
          { Draw text }
          if (Document <> nil) and (Document.UnitType = Centimeter) then
            TextOut(Pt.X + 2, RulerMargin, IntToStr(Round(Tics / 10)))
          else
            TextOut(Pt.X + 2, RulerMargin, IntToStr(Trunc(Tics)));