frxexportmatrix.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

    Result := 0;
end;

function TfrxIEMatrix.GetPageWidth(Page: integer): Extended;
begin
  if Page < FPages.Count then
    Result := TfrxIEMPage(FPages[Page]).Width
  else
    Result := 0;
end;

function TfrxIEMatrix.GetPageBMargin(Page: integer): Extended;
begin
  if Page < FPages.Count then
    Result := TfrxIEMPage(FPages[Page]).BottomMargin
  else
    Result := 0;
end;

function TfrxIEMatrix.GetPageRMargin(Page: integer): Extended;
begin
  if Page < FPages.Count then
    Result := TfrxIEMPage(FPages[Page]).RightMargin
  else
    Result := 0;
end;

function TfrxIEMatrix.GetPageOrientation(Page: integer): TPrinterOrientation;
begin
  if Page < FPages.Count then
    Result := TfrxIEMPage(FPages[Page]).Orientation
  else
    Result := poPortrait;
end;

function TfrxIEMatrix.GetPagesCount: Integer;
begin
  Result := FPages.Count;
end;

function TfrxIEMatrix.GetStyle(x, y: integer): TfrxIEMStyle;
var
  Obj: TfrxIEMObject;
begin
  Obj := GetObject(x, y);
  if Obj <> nil then
    Result := TfrxIEMStyle(FIEMStyleList[Obj.StyleIndex])
  else
    Result := nil;
end;

function TfrxIEMatrix.GetStyleById(StyleIndex: integer): TfrxIEMStyle;
begin
  Result := TfrxIEMStyle(FIEMStyleList[StyleIndex]);
end;

function TfrxIEMatrix.GetStylesCount: Integer;
begin
  Result := FIEMStyleList.Count;
end;

function TfrxIEMatrix.GetXPosById(PosIndex: integer): Extended;
begin
  Result := TfrxIEMPos(FXPos[PosIndex]).Value;
end;

function TfrxIEMatrix.GetYPosById(PosIndex: integer): Extended;
begin
  Result := TfrxIEMPos(FYPos[PosIndex]).Value;
end;

function TfrxIEMatrix.IsMemo(Obj: TfrxView): boolean;
begin
  Result := (Obj is TfrxCustomMemoView) and
            (Obj.BrushStyle in [bsSolid, bsClear]) and
            ((TfrxCustomMemoView(Obj).Rotation = 0) or (not FRotatedImage));
end;

function TfrxIEMatrix.IsLine(Obj: TfrxView): boolean;
begin
  Result := (Obj is TfrxCustomLineView) and ((Obj.Width = 0) or (Obj.Height = 0));
end;

function TfrxIEMatrix.IsRect(Obj: TfrxView): boolean;
begin
  Result := (Obj is TfrxShapeView) and (TfrxShapeView(Obj).Shape = skRectangle);
end;

procedure TfrxIEMatrix.OptimizeFrames;
var
  x, y: Integer;
  Obj, PrevObj: TfrxIEMObject;
  FrameTyp: TfrxFrameTypes;
  Style: TfrxIEMStyle;
begin
  for y := 0 to Height - 1 do
    for x := 0 to Width - 1 do
    begin
      Obj := GetObject(x, y);
      if Obj = nil then continue;
      FrameTyp := Obj.Style.FrameTyp;

      if (ftTop in FrameTyp) and (y > 0) then
      begin
        PrevObj := GetObject(x, y - 1);
        if (PrevObj <> nil) and (PrevObj <> Obj) then
          if (ftBottom in PrevObj.Style.FrameTyp) and
            (PrevObj.Style.FrameWidth = Obj.Style.FrameWidth) and
            (PrevObj.Style.FrameColor = Obj.Style.FrameColor) then
            FrameTyp := FrameTyp - [ftTop];
      end;
      if (ftLeft in FrameTyp) and (x > 0) then
      begin
        PrevObj := GetObject(x - 1, y);
        if (PrevObj <> nil) and (PrevObj <> Obj) then
          if (ftRight in PrevObj.Style.FrameTyp) and
            (PrevObj.Style.FrameWidth = Obj.Style.FrameWidth) and
            (PrevObj.Style.FrameColor = Obj.Style.FrameColor) then
            FrameTyp := FrameTyp - [ftLeft];
      end;

      if FrameTyp <> Obj.Style.FrameTyp then
      begin
        Style := TfrxIEMStyle.Create;
        Style.Assign(Obj.Style);
        Style.FrameTyp := FrameTyp;
        Obj.StyleIndex := AddStyleInternal(Style);
        Obj.Style := TfrxIEMStyle(FIEMStyleList[Obj.StyleIndex]);
      end;
    end;
end;

function TfrxIEMatrix.QuickFind(aList: TList; aPosition: Extended; var Index: Integer): Boolean;
var
  L, H, I: Integer;
  C: Extended;
begin
  Result := False;
  L := 0;
  H := aList.Count - 1;
  while L <= H do begin
    I := (L + H) shr 1;
    C := TfrxIEMPos(aList[I]).Value - aPosition;
    if C < 0 then
      L := I + 1
    else begin
      H := I - 1;
      if C = 0 then begin
        Result := True;
        L := I
      end
    end
  end;
  Index := L
end;

procedure TfrxIEMatrix.OrderByCells;
var
  i, j, k, dx, dy: integer;
  curx, cury: Extended;
  obj: TfrxIEMObject;
begin
  OrderPosArray(FXPos, false);
  OrderPosArray(FYPos, true);
  for i := 0 to FIEMObjectList.Count - 1 do
  begin
    dx := 0; dy := 0;
    obj := TfrxIEMObjectList(FIEMObjectList[i]).Obj;
    QuickFind(FXPos, Obj.Left, j);
    if j < FXPos.Count then
    begin
      TfrxIEMObjectList(FIEMObjectList[i]).x := j;
      curx := Obj.Left;
      k := j;
      while (Obj.Left + Obj.Width > curx) and (k < FXPos.Count - 1) do
      begin
        Inc(k);
        curx := TfrxIEMPos(FXPos[k]).Value;
        Inc(dx);
      end;
      TfrxIEMObjectList(FIEMObjectList[i]).dx := dx;
    end;
    QuickFind(FYPos, Obj.Top, j);
    if j < FYPos.Count then
    begin
      TfrxIEMObjectList(FIEMObjectList[i]).y := j;
      cury := Obj.Top;
      k := j;
      while (Obj.Top + Obj.Height > cury) and (k < FYPos.Count - 1) do
      begin
        Inc(k);
        cury := TfrxIEMPos(FYPos[k]).Value;
        Inc(dy);
      end;
      TfrxIEMObjectList(FIEMObjectList[i]).dy := dy;
    end;
  end;
  if FShowProgress then
    FProgress.Tick;
end;

function SortPosCompare(Item1, Item2: Pointer): Integer;
begin
  if TfrxIEMPos(Item1).Value < TfrxIEMPos(Item2).Value then
    Result := -1
  else if TfrxIEMPos(Item1).Value > TfrxIEMPos(Item2).Value then
    Result := 1
  else
    Result := 0;
end;

procedure TfrxIEMatrix.OrderPosArray(List: TList; Vert: boolean);
var
  i, j, Cnt: integer;
  pos1, pos2: Extended;
  Reorder: Boolean;
begin
  List.Sort(SortPosCompare);
  if FShowProgress then
    FProgress.Tick;
  i := 0;
  while i <= List.Count - 2 do
  begin
    pos1 := TfrxIEMPos(List[i]).Value;
    pos2 := TfrxIEMPos(List[i + 1]).Value;
    if pos2 - pos1 < FInaccuracy then
    begin
      TfrxIEMPos(List[i]).Free;
      List.Delete(i);
    end else Inc(i);
  end;
  if FShowProgress then
    FProgress.Tick;
  Reorder := False;
  if Vert and (FMaxCellHeight > 0) then
    for i := 0 to List.Count - 2 do
    begin
      pos1 := TfrxIEMPos(List[i]).Value;
      pos2 := TfrxIEMPos(List[i + 1]).Value;
      if pos2 - pos1 > FMaxCellHeight then
      begin
        Cnt := Round(Int((pos2 - pos1) / FMaxCellHeight));
        for j := 1 to Cnt do
          AddPos(List, pos1 + FMaxCellHeight * j);
        Reorder := True;
      end;
    end;
  if FShowProgress then
    FProgress.Tick;
  if (not Vert) and (FMaxCellWidth > 0) then
    for i := 0 to List.Count - 2 do
    begin
      pos1 := TfrxIEMPos(List[i]).Value;
      pos2 := TfrxIEMPos(List[i + 1]).Value;
      if pos2 - pos1 > FMaxCellWidth then
      begin
        Cnt := Round(Int((pos2 - pos1) / FMaxCellWidth));
        for j := 1 to Cnt do
          AddPos(List, pos1 + FMaxCellWidth * j);
        Reorder := True;
      end;
    end;
  if Reorder then
    List.Sort(SortPosCompare);
  if FShowProgress then
    FProgress.Tick;
end;

procedure TfrxIEMatrix.Prepare;
var
  Style: TfrxIEMStyle;
  FObj: TfrxIEMObject;
  FObjItem: TfrxIEMObjectList;

begin
  if FShowProgress then
  begin
    FProgress := TfrxProgress.Create(nil);
    FProgress.Execute(11, frxResources.Get('ProgressWait'), false, true);
  end;
  if FFillArea then
  begin
    Style := TfrxIEMStyle.Create;
    Style.FrameTyp := [];
    Style.Color := clWhite;
    FObj := TfrxIEMObject.Create;
    FObj.StyleIndex := AddStyleInternal(Style);
    FObj.Style := Style;
    if FCropFillArea then
    begin
      FObj.Left := FMinLeft;
      FObj.Top := FMinTop;
    end
    else
    begin
      FObj.Left := 0;
      FObj.Top := 0;
    end;
    FObj.Width := MaxWidth;
    FObj.Height := MaxHeight;
    FObj.IsText := True;
    AddPos(FXPos, 0);
    AddPos(FYPos, 0);
    FObjItem := TfrxIEMObjectList.Create;
    FObjItem.x := 0;
    FObjItem.y := 0;
    FObjItem.dx := 1;
    FObjItem.dy := 1;
    FObjItem.Obj := FObj;
    FIEMObjectList.Insert(0, FObjItem);
  end;
  OrderByCells;
  FWidth := FXPos.Count;
  FHeight := FYPos.Count;
  Render;
  Analyse;
  if FOptFrames then
    OptimizeFrames;
  if FShowProgress then
    FProgress.Free;
end;

procedure TfrxIEMatrix.Render;
var
  i, old: integer;
  obj: TfrxIEMObjectList;
  Style: TfrxIEMStyle;
  OldColor: TColor;
begin
  SetLength(FMatrix, FWidth * FHeight);
  FillArea(0, 0, FWidth, FHeight, -1);
  for i := 0 to FIEMObjectList.Count - 1 do
  begin
    obj := TfrxIEMObjectList(FIEMObjectList[i]);
    if (Obj.Obj.Style <> nil) and (Obj.Obj.Style.Color = clNone) then
    begin
      old := GetCell(obj.x, obj.y);
      if old <> -1 then
      begin
        OldColor := TfrxIEMObjectList(FIEMObjectList[Old]).Obj.Style.Color;
        if (OldColor <> Obj.Obj.Style.Color) and (OldColor <> Obj.Obj.Style.Font.Color) then
        begin
          Style := TfrxIEMStyle.Create;
          Style.Assign(Obj.Obj.Style);
          Style.Color := OldColor;
          Obj.Obj.StyleIndex := AddStyleInternal(Style);
          Obj.Obj.Style := TfrxIEMStyle(FIEMStyleList[Obj.Obj.StyleIndex]);
        end;
      end;
    end;
    FillArea(obj.x, obj.y, obj.dx, obj.dy, i);
  end;
  if FShowProgress then
    FProgress.Tick;
end;

procedure TfrxIEMatrix.ReplaceArea(ObjIndex, x, y, dx, dy, Value: integer);
var
  i, j: integer;
begin
  for i := y to y + dy - 1 do
    for j := x to x + dx - 1 do
      if GetCell(j, i) = ObjIndex then
        SetCell(j, i, Value);
end;

procedure TfrxIEMatrix.SetCell(x, y, Value: integer);
begin
  if (x < FWidth) and (y < FHeight) and (x >= 0) and (y >= 0) then
    FMatrix[FWidth * y + x] := Value;
end;


{ TfrxIEMObjectList }

constructor TfrxIEMObjectList.Create;
begin
  Exist := False;
end;

destructor TfrxIEMObjectList.Destroy;
begin
  Obj.Free;
  inherited;
end;

{ TfrxIEMStyle }

procedure TfrxIEMStyle.Assign(Style: TfrxIEMStyle);
begin
  Font.Assign(Style.Font);
  LineSpacing := Style.LineSpacing;
  GapX := Style.GapX;
  GapY := Style.GapY;
  VAlign := Style.VAlign;
  HAlign := Style.HAlign;
  FrameTyp := Style.FrameTyp;
  FrameWidth := Style.FrameWidth;
  FrameColor := Style.FrameColor;
  FrameStyle := Style.FrameStyle;
  Color := Style.Color;
  Rotation := Style.Rotation;
  BrushStyle := Style.BrushStyle;
end;

constructor TfrxIEMStyle.Create;
begin
  Font := TFont.Create;
end;

destructor TfrxIEMStyle.Destroy;
begin
  Font.Free;
  inherited;
end;

{ TfrxIEMObject }

constructor TfrxIEMObject.Create;
begin
  FMemo := TStringList.Create;
  FDisplayFormat := TfrxFormat.Create;
  FDisplayFormat.DecimalSeparator := '';
  FDisplayFormat.FormatStr := '';
  FDisplayFormat.Kind := fkText;
  Left := 0;
  Top := 0;
  Image := nil;
  FParent := nil;
  FCounter := 0;
  FIsText := true;
  FIsRichText := false;
  FIsDialogObject := False;
  FLink := nil;
end;

destructor TfrxIEMObject.Destroy;
begin
  FMemo.Free;
  FDisplayFormat.Free;
  if Assigned(FImage) then
    FImage.Free;
  inherited;
end;

procedure TfrxIEMObject.SetDisplayFormat(const Value: TfrxFormat);
begin
  FDisplayFormat.Assign(Value);
end;

procedure TfrxIEMObject.SetMemo(const Value: TStrings);
begin
  FMemo.Assign(Value);
end;

end.