frxexportmatrix.pas

这个是功能强大的报表软件

      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;
  i, j: Integer;
  f: Boolean;
{$IFDEF FR_DEBUG}
  FLines: TStrings;
  s, s1: String;
{$ENDIF}
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;

{$IFDEF FR_DEBUG}
  FLines := TStringList.Create;
  try
    for i := 0 to Height - 1 do
    begin
      s := Format('%10f', [TfrxIEMPos(FYPos[i]).Value]) + ' |';
      for j := 0 to Width - 1 do
      begin
        if GetCell(j, i) <> -1 then
          s1 := GetObject(j, i).Memo.Text
        else
          s1 := '';
        s := s + ' ' + Format('%6d', [GetCell(j, i)]) + '/' + Copy(s1, 1, 5);
      end;
      FLines.Add(s);
    end;
    FLines.SaveToFile('matrix_before.log');
  finally
    FLines.Free;
  end;
{$ENDIF}

  if not FEmptyLines then
  begin
    i := 0;
    while i < Height - 1 do
    begin
      f := True;
      for j := 0 to Width - 1 do
        f := f and (GetCell(j, i) = - 1);
      if f then
        DeleteMatrixLine(i)
      else
        Inc(i);
    end;
  end;

{$IFDEF FR_DEBUG}
  FLines := TStringList.Create;
  try
    for i := 0 to Height - 1 do
    begin
      s := Format('%10f', [TfrxIEMPos(FYPos[i]).Value]) + ' |';
     for j := 0 to Width - 1 do
        s := s + ' ' + Format('%6d', [GetCell(j, i)]);
      FLines.Add(s);
    end;
    FLines.SaveToFile('matrix_after.log');
  finally
    FLines.Free;
  end;
{$ENDIF}
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
        FMatrix[FWidth * i + j] := 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;

procedure TfrxIEMatrix.DeleteMatrixLine(y: Integer);
var
  i, j: Integer;
  delta: Extended;
begin
  if (y >= 0) and (y < FHeight) then
  begin
    if (y < FHeight - 1) then
      delta := TfrxIEMPos(FYPos[y + 1]).Value - TfrxIEMPos(FYPos[y]).Value
    else
      delta := 0;
    for i := 1 to FHeight - y - 1 do
      TfrxIEMPos(FYPos[y + i]).Value := TfrxIEMPos(FYPos[y + i]).Value - delta;
    if Assigned(TfrxIEMPos(FYPos[y])) then
      TfrxIEMPos(FYPos[y]).Free;
    FYPos.Delete(y);
    j := FWidth * (FHeight - y - 1);
    for i := 0 to j - 1 do
      FMatrix[FWidth * y + i] := FMatrix[FWidth * (y + 1) + i];
    Dec(FHeight);
  end;
end;

function TfrxIEMatrix.GetFontCharset(Font: TFont): Integer;
var
  b: TBitmap;
  pm: ^OUTLINETEXTMETRIC;
  i: Cardinal;
begin
  Result := 0;
  if FFontList.IndexOf(Font.Name) <> -1 then
    Result := StrToInt(FFontList.Values[Font.Name])
  else
  begin
    b := TBitmap.Create;
    try
      b.Canvas.Lock;
      b.Canvas.Font.Assign(Font);
      i := GetOutlineTextMetrics(b.Canvas.Handle, 0, nil);
      if i = 0 then
      begin
        b.Canvas.Font.Name := 'Arial';
        i := GetOutlineTextMetrics(b.Canvas.Handle, 0, nil);
      end;
      if i <> 0 then
      begin
        pm := GlobalAllocPtr(GMEM_MOVEABLE or GMEM_SHARE, i);
        try
          if pm <> nil then
            i := GetOutlineTextMetrics(b.Canvas.Handle, i, pm)
          else
            i := 0;
          if i <> 0 then
          begin
            Result := pm.otmTextMetrics.tmCharSet;
            FFontList.Add(Font.Name);
            FFontList.Values[Font.Name] := IntToStr(Result);
          end;
        finally
          GlobalFreePtr(pm);
        end;
      end;
    finally
      b.Canvas.Unlock;
      b.Free;
    end;
  end;
end;

procedure TfrxIEMatrix.SetPageFooter(Band: TfrxBand);
begin
  FFooter := Band;
end;

procedure TfrxIEMatrix.SetPageHeader(Band: TfrxBand);
begin
  FHeader := Band;
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);
  FDisplayFormat.Assign(Style.DisplayFormat);
  LineSpacing := Style.LineSpacing;
  GapX := Style.GapX;
  GapY := Style.GapY;
  ParagraphGap := Style.ParagraphGap;
  CharSpacing := Style.CharSpacing;
  Charset := Style.Charset;
  WordBreak := Style.WordBreak;
  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;
  FDisplayFormat := TfrxFormat.Create;
  FDisplayFormat.DecimalSeparator := '';
  FDisplayFormat.FormatStr := '';
  FDisplayFormat.Kind := fkText;
end;

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

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

{ TfrxIEMObject }

constructor TfrxIEMObject.Create;
begin
{$IFDEF Delphi10}
  FMemo := TfrxWideStrings.Create;
{$ELSE}
  FMemo := TWideStrings.Create;
{$ENDIF}
  FMetafile := TMetafile.Create;
  Left := 0;
  Top := 0;
  Image := nil;
  FParent := nil;
  FCounter := 0;
  FIsText := true;
  FIsRichText := false;
  FIsDialogObject := False;
  FLink := nil;
  FHTMLTags := False;
end;

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

function TfrxIEMObject.GetImage: TBitmap;
begin
  Result := FImage;
end;

procedure TfrxIEMObject.SetImage(const Value: TBitmap);
begin
  FImage := Value;
end;

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

end.