fr_desgn.pas

FreeReport 2.34 consists of the report engine, designer and previewer, with capabilities comparable

    property Units: TfrReportUnits read FUnits write SetUnits;
    property GrayedButtons: Boolean read FGrayedButtons write SetGrayedButtons;
  end;

procedure frSetGlyph(Color: TColor; sb: TfrSpeedButton; n: Integer);
function frCheckBand(b: TfrBandType): Boolean;

var
  frTemplateDir: String;


implementation

{$R *.DFM}
{$R *.RES}
{$R FR_Lng2.RES}

uses
  ShellApi,
  FR_Pgopt, FR_GEdit, FR_Templ, FR_Newrp, FR_DsOpt, FR_Const,
  FR_Prntr, FR_Hilit, FR_Flds, FR_Dopt, FR_Ev_ed, FR_BndEd, FR_VBnd,
  FR_BTyp, FR_Utils, FR_GrpEd, FR_About, FR_IFlds, FR_Pars, FR_DBRel,
  FR_DBSet, Registry
{$IFNDEF IBO}
  , DB
{$ENDIF};

type
  THackView = class(TfrView)
  end;

function GetUnusedBand: TfrBandType; forward;
procedure SendBandsToDown; forward;
procedure ClearClipBoard; forward;
function Objects: TList; forward;
procedure GetRegion; forward;
function TopSelected: Integer; forward;

var
  FirstInst: Boolean = True;
  FirstSelected: TfrView;
  SelNum: Integer;               // number of objects currently selected
  MRFlag,                        // several objects was selected
  ObjRepeat,                     // was pressed Shift + Insert Object
  WasOk: Boolean;                // was Ok pressed in dialog
  OldRect, OldRect1: TRect;      // object rect after mouse was clicked
  Busy: Boolean;                 // busy flag. need!
  ShowSizes: Boolean;
  LastFontName: String;
  LastFontSize, LastAdjust: Integer;
  LastFrameWidth, LastLineWidth: Single;
  LastFrameTyp, LastFontStyle: Word;
  LastFrameColor, LastFillColor, LastFontColor: TColor;
  ClrButton: TfrSpeedButton;
  FirstChange: Boolean;
  ClipRgn: HRGN;

// globals
  ClipBd: TList;                 // clipboard
  GridBitmap: TBitmap;           // for drawing grid in design time


{----------------------------------------------------------------------------}
procedure TfrDesigner.Loaded;
begin
  inherited Loaded;
  frTemplateDir := TemplateDir;
end;

{--------------------------------------------------}
constructor TfrDesignerPage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Parent := AOwner as TWinControl;
  BevelInner := bvNone;
  BevelOuter := bvNone;
  Color  := clWhite;
  BorderStyle := bsNone;
  OnMouseDown := MDown;
  OnMouseUp := MUp;
  OnMouseMove := MMove;
  OnDblClick := DClick;
end;

procedure TfrDesignerPage.Init;
begin
  Down := False; DFlag := False; RFlag := False;
  Cursor := crDefault; CT := ctNone;
end;

procedure TfrDesignerPage.SetPage;
var
  Pgw,Pgh: Integer;
begin
  if Assigned(FDesigner.Page) then
  begin
  Pgw := FDesigner.Page.PrnInfo.Pgw;
  Pgh := FDesigner.Page.PrnInfo.Pgh;
  if Pgw > Parent.Width then
    SetBounds(10, 10, Pgw, Pgh) else
    SetBounds((Parent.Width - Pgw) div 2, 10, Pgw, Pgh);
  FDesigner.BPanel.Top := Top + Height + 10;
  FDesigner.RPanel.Left := Left + Width + 10;
  end;
end;

procedure TfrDesignerPage.Paint;
begin
  Draw(10000, 0);
end;

procedure TfrDesignerPage.NormalizeCoord(t: TfrView);
begin
  if t.dx < 0 then
  begin
    t.dx := -t.dx;
    t.x := t.x - t.dx;
  end;
  if t.dy < 0 then
  begin
    t.dy := -t.dy;
    t.y := t.y - t.dy;
  end;
end;

procedure TfrDesignerPage.NormalizeRect(var r: TRect);
var
  i: Integer;
begin
  with r do
  begin
    if Left > Right then begin i := Left; Left := Right; Right := i end;
    if Top > Bottom then begin i := Top; Top := Bottom; Bottom := i end;
  end;
end;

procedure TfrDesignerPage.DrawHSplitter(Rect: TRect);
begin
  with Canvas do
  begin
    Pen.Mode := pmXor;
    Pen.Color := clSilver;
    Pen.Width := 1;
    MoveTo(Rect.Left, Rect.Top);
    LineTo(Rect.Right, Rect.Bottom);
    Pen.Mode := pmCopy;
  end;
end;

procedure TfrDesignerPage.DrawRectLine(Rect: TRect);
begin
  with Canvas do
  begin
    Pen.Mode := pmNot;
    Pen.Style := psSolid;
    Pen.Width := Round(LastLineWidth);
    with Rect do
      if Abs(Right - Left) > Abs(Bottom - Top) then
      begin
        MoveTo(Left, Top);
        LineTo(Right, Top);
      end
      else
      begin
        MoveTo(Left, Top);
        LineTo(Left, Bottom);
      end;
    Pen.Mode := pmCopy;
  end;
end;

procedure TfrDesignerPage.DrawFocusRect(Rect: TRect);
begin
  with Canvas do
  begin
    Pen.Mode := pmXor;
    Pen.Color := clSilver;
    Pen.Width := 1;
    Pen.Style := psSolid;
    Brush.Style := bsClear;
    if (Rect.Right = Rect.Left + 1) or (Rect.Bottom = Rect.Top + 1) then
    begin
      if Rect.Right = Rect.Left + 1 then
        Dec(Rect.Right, 1) else
        Dec(Rect.Bottom, 1);
      MoveTo(Rect.Left, Rect.Top);
      LineTo(Rect.Right, Rect.Bottom);
    end
    else
      Rectangle(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom);
    Pen.Mode := pmCopy;
    Brush.Style := bsSolid;
  end;
end;

procedure TfrDesignerPage.DrawSelection(t: TfrView);
var
  px, py: Word;
  procedure DrawPoint(x, y: Word);
  begin
    Canvas.MoveTo(x, y);
    Canvas.LineTo(x, y);
  end;
begin
  if t.Selected then
  with t, Canvas do
  begin
    Pen.Width := 5;
    Pen.Mode := pmXor;
    Pen.Color := clWhite;
    px := x + dx div 2;
    py := y + dy div 2;
    DrawPoint(x, y); DrawPoint(x + dx, y);
    DrawPoint(x, y + dy);
    if Objects.IndexOf(t) = RightBottom then
      Pen.Color := clTeal;
    DrawPoint(x + dx, y + dy);
    Pen.Color := clWhite;
    if SelNum = 1 then
    begin
      DrawPoint(px, y); DrawPoint(px, y + dy);
      DrawPoint(x, py); DrawPoint(x + dx, py);
    end;
    Pen.Mode := pmCopy;
  end;
end;

procedure TfrDesignerPage.DrawShape(t: TfrView);
begin
  if t.Selected then
  with t do
    DrawFocusRect(Rect(x, y, x + dx + 1, y + dy + 1))
end;

procedure TfrDesignerPage.Draw(N: Integer; ClipRgn: HRGN);
var
  i: Integer;
  t: TfrView;
  R, R1: HRGN;
  Objects: TList;
  procedure DrawBackground;
  var
    i, j: Integer;
  begin
    with Canvas do
    begin
      if FDesigner.ShowGrid and (FDesigner.GridSize <> 18) then
      begin
        with GridBitmap.Canvas do
        begin
          Brush.Color := clWhite;
          FillRect(Rect(0, 0, 8, 8));
          Pixels[0, 0] := clBlack;
          if FDesigner.GridSize = 4 then
          begin
            Pixels[4, 0] := clBlack;
            Pixels[0, 4] := clBlack;
            Pixels[4, 4] := clBlack;
          end;
        end;
        Brush.Bitmap := GridBitmap;
      end
      else
      begin
        Brush.Color := clWhite;
        Brush.Style := bsSolid;
      end;
      FillRgn(Handle, R, Brush.Handle);
      if FDesigner.ShowGrid and (FDesigner.GridSize = 18) then
      begin
        i := 0;
        while i < Width do
        begin
          j := 0;
          while j < Height do
          begin
            if RectVisible(Handle, Rect(i, j, i + 1, j + 1)) then
              SetPixel(Handle, i, j, clBlack);
            Inc(j, FDesigner.GridSize);
          end;
          Inc(i, FDesigner.GridSize);
        end;
      end;
      Brush.Style := bsClear;
      Pen.Width := 1;
      Pen.Color := clGray;
      Pen.Style := psSolid;
      Pen.Mode := pmCopy;
      with FDesigner.Page do
      begin
        if UseMargins then
          Rectangle(LeftMargin, TopMargin, RightMargin, BottomMargin);
        if ColCount > 1 then
        begin
          ColWidth := (RightMargin - LeftMargin) div ColCount;
          Pen.Style := psDot;
          j := LeftMargin;
          for i := 1 to ColCount do
          begin
            Rectangle(j, -1, j + ColWidth + 1,  PrnInfo.Pgh + 1);
            Inc(j, ColWidth + ColGap);
          end;
          Pen.Style := psSolid;
        end;
      end;
    end;
  end;
  function IsVisible(t: TfrView): Boolean;
  var
    R: HRGN;
  begin
    R := t.GetClipRgn(rtNormal);
    Result := CombineRgn(R, R, ClipRgn, RGN_AND) <> NULLREGION;
    DeleteObject(R);
  end;

begin
  if FDesigner.Page = nil then Exit;
  DocMode := dmDesigning;
  Objects := FDesigner.Page.Objects;
  if ClipRgn = 0 then
    with Canvas.ClipRect do
      ClipRgn := CreateRectRgn(Left, Top, Right, Bottom);
  R := CreateRectRgn(0, 0, Width, Height);
  for i := Objects.Count - 1 downto 0 do
  begin
    t := Objects[i];
    if i <= N then
      if t.Selected then
        t.Draw(Canvas)
      else if IsVisible(t) then
      begin
        R1 := CreateRectRgn(0, 0, 1, 1);
        CombineRgn(R1, ClipRgn, R, RGN_AND);
        SelectClipRgn(Canvas.Handle, R1);
        DeleteObject(R1);
        t.Draw(Canvas);
      end;
    R1 := t.GetClipRgn(rtNormal);
    CombineRgn(R, R, R1, RGN_DIFF);
    DeleteObject(R1);
    SelectClipRgn(Canvas.Handle, R);
  end;
  CombineRgn(R, R, ClipRgn, RGN_AND);
  DrawBackground;

  DeleteObject(R);
  DeleteObject(ClipRgn);
  SelectClipRgn(Canvas.Handle, 0);
  if not Down then
    DrawPage(dmSelection);
end;

procedure TfrDesignerPage.DrawPage(DrawMode: TfrDesignerDrawMode);
var
  i: Integer;
  t: TfrView;
begin
  if DocMode <> dmDesigning then Exit;
  for i := 0 to Objects.Count - 1 do
  begin
    t := Objects[i];
    case DrawMode of
      dmAll: t.Draw(Canvas);
      dmSelection: DrawSelection(t);
      dmShape: DrawShape(t);
    end;
  end;
end;

function TfrDesignerPage.FindNearestEdge(var x, y: Integer): Boolean;
var
  i: Integer;
  t: TfrView;
  min: Double;
  p: TPoint;
  function DoMin(a: Array of TPoint): Boolean;
  var
    i: Integer;
    d: Double;
  begin
    Result := False;
    for i := Low(a) to High(a) do
    begin
      d := sqrt((x - a[i].x) * (x - a[i].x) + (y - a[i].y) * (y - a[i].y));
      if d < min then
      begin
        min := d;
        p := a[i];
        Result := True;
      end;
    end;
  end;
begin
  Result := False;
  min := FDesigner.GridSize;
  p := Point(x, y);
  for i := 0 to Objects.Count - 1 do
  begin
    t := Objects[i];
    if DoMin([Point(t.x, t.y), Point(t.x + t.dx, t.y),
         Point(t.x + t.dx, t.y + t.dy),  Point(t.x, t.y + t.dy)]) then
      Result := True;
  end;
  x := p.x; y := p.y;
end;

procedure TfrDesignerPage.RoundCoord(var x, y: Integer);
begin
  with FDesigner do
    if GridAlign then
    begin
      x := x div GridSize * GridSize;
      y := y div GridSize * GridSize;
    end;
end;

procedure TfrDesignerPage.GetMultipleSelected;
var
  i, j, k: Integer;
  t: TfrView;
begin
  j := 0; k := 0;
  LeftTop := Point(10000, 10000);
  RightBottom := -1;
  MRFlag := False;
  if SelNum > 1 then                  {find right-bottom element}
  begin
    for i := 0 to Objects.Count-1 do
    begin
      t := Objects[i];
      if t.Selected then
      begin
        t.OriginalRect := Rect(t.x, t.y, t.dx, t.dy);
        if (t.x + t.dx > j) or ((t.x + t.dx = j) and (t.y + t.dy > k)) then
        begin
          j := t.x + t.dx;
          k := t.y + t.dy;
          RightBottom := i;
        end;
        if t.x < LeftTop.x then LeftTop.x := t.x;
        if t.y < LeftTop.y then LeftTop.y := t.y;
      end;
    end;
    t := Objects[RightBottom];
    OldRect := Rect(LeftTop.x, LeftTop.y, t.x + t.dx, t.y + t.dy);
    OldRect1 := OldRect;
    MRFlag := True;
  end;
end;

procedure TfrDesignerPage.MDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  i: Integer;
  f, DontChange, v: Boolean;
  t: TfrView;
  Rgn: HRGN;
  p: TPoint;
begin
  if DFlag then
  begin