frxexportxls.pas

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

    else
      FMatrix.Inaccuracy := 10;
    FMatrix.RotatedAsImage := False;
    FMatrix.DeleteHTMLTags := True;
    FMatrix.Printable := ExportNotPrintable;
    FExcel := TfrxExcel.Create;
    FExcel.OpenExcel;
    Result := True;
  end
  else
    Result := False;
end;

procedure TfrxXLSExport.StartPage(Page: TfrxReportPage; Index: Integer);
begin
  if FFirstPage then
  begin
    FFirstPage := False;
    FPageLeft := Page.LeftMargin;
    FPageTop := Page.TopMargin;
    FPageBottom := Page.BottomMargin;
    FPageRight := Page.RightMargin;
    FPageOrientation := Page.Orientation;
  end;
end;

procedure TfrxXLSExport.ExportObject(Obj: TfrxComponent);
begin
  if Obj is TfrxView then
    if (Obj is TfrxCustomMemoView) or
      (FExportPictures and (not (Obj is TfrxCustomMemoView))) then
        FMatrix.AddObject(TfrxView(Obj));
end;

procedure TfrxXLSExport.FinishPage(Page: TfrxReportPage; Index: Integer);
begin
  FMatrix.AddPage(Page.Orientation, Page.Width, Page.Height, Page.LeftMargin,
                  Page.TopMargin, Page.RightMargin, Page.BottomMargin);
end;

procedure TfrxXLSExport.Finish;
begin
  FMatrix.Prepare;
  try
    if FFastExport then
      ExportPage_Fast
    else
      ExportPage;
    FExcel.SetRange(1, 1, 1, 1);
    FExcel.Range.Select;
    if FOpenExcelAfterExport then
      FExcel.Visible := True;
  finally
    try
      try
        FExcel.WorkBook.SaveAs(FileName, xlNormal, EmptyParam,
          EmptyParam, EmptyParam, EmptyParam, xlNoChange, EmptyParam, EmptyParam, EmptyParam);
      finally
        FExcel.Excel.Application.ScreenUpdating := True;
      end;
      if not FOpenExcelAfterExport then
      begin
        FExcel.Excel.Quit;
        FExcel.Excel := Null;
        FExcel.Excel := Unassigned;
      end;
    except
    end;
  end;
  FMatrix.Free;
  FExcel.Free;
end;


{ TfrxExcel }

constructor TfrxExcel.Create;
begin
  inherited Create;
  FIsOpened := False;
  FIsVisible := False;
end;

function TfrxExcel.Pos2Str(Pos: Integer): String;
var
  i, j: Integer;
begin
  if Pos > 26 then
  begin
    i := Pos mod 26;
    j := Pos div 26;
    if i = 0 then
      Result := Chr(64 + j - 1)
    else
      Result := Chr(64 + j);
    if i = 0 then
      Result := Result + chr(90)
    else
      Result := Result + Chr(64 + i);
  end
  else
    Result := Chr(64 + Pos);
end;

procedure TfrxExcel.SetVisible(DoShow: Boolean);
begin
  if not FIsOpened then Exit;
  if DoShow then
    Excel.Visible := True
  else
    Excel.Visible := False;
end;

function TfrxExcel.IntToCoord(X, Y: Integer): String;
begin
  Result := Pos2Str(X) + IntToStr(Y);
end;

procedure TfrxExcel.SetColSize(x: Integer; Size: Extended);
var
  r: Variant;
begin
  if (Size > 0) and (Size < 256) and (x < 256) then
  begin
    try
      r := WorkSheet.Columns;
      r.Columns[x].ColumnWidth := Size;
    except
    end;
  end;
end;

procedure TfrxExcel.SetRowSize(y: Integer; Size: Extended);
var
  r: Variant;
begin
  if Size > 0 then
  begin
    r := WorkSheet.Rows;
    if size > 409 then
      size := 409;
    r.Rows[y].RowHeight := Size;
  end;
end;

procedure TfrxExcel.MergeCells;
begin
  Range.MergeCells := True;
end;

procedure TfrxExcel.OpenExcel;
begin
  try
    Excel := CreateOLEObject('Excel.Application');
    Excel.Application.ScreenUpdating := False;
    WorkBook := Excel.WorkBooks.Add;
    WorkSheet := WorkBook.WorkSheets[1];
    FIsOpened := True;
  except
    FIsOpened := False;
  end;
end;

procedure TfrxExcel.SetPageMargin(Left, Right, Top, Bottom: Extended;
  Orientation: TPrinterOrientation);
var
  Orient: Integer;
begin
  if Orientation = poLandscape then
    Orient := 2
  else
    Orient := 1;
  try
    Excel.ActiveSheet.PageSetup.LeftMargin := Left;
    Excel.ActiveSheet.PageSetup.RightMargin := Right;
    Excel.ActiveSheet.PageSetup.TopMargin := Top;
    Excel.ActiveSheet.PageSetup.BottomMargin := Bottom;
    Worksheet.PageSetup.Orientation := Orient;
  except
  end;
end;

procedure TfrxExcel.SetRange(x, y, dx, dy: Integer);
begin
  try
    if x > 255 then
      x := 255;
    if (x + dx) > 255 then
      dx := 255 - x;
    if (dx > 0) and (dy > 0) then
      Range := WorkSheet.Range[IntToCoord(x, y), IntToCoord(x + dx - 1, y + dy - 1)];
  except
  end;
end;

procedure TfrxExcel.SetRowsSize(aRanges: TStrings;
  Sizes: array of Currency; MainSizeIndex: integer;
  RowsCount:integer; aProgress: TfrxProgress);
var
  i: integer;
  s: string;
  curSizes: integer;
  v: Variant;
begin
  if aRanges.Count > 0 then
  begin
    if Assigned(aProgress) then
      if not aProgress.Terminated then
      begin
        s := frxResources.Get('ProgressRows') + ' - 2';
        aProgress.Execute(aRanges.Count, s, True, True);
        WorkSheet.Range['A1:A' + IntToStr(RowsCount)].RowHeight := Sizes[MainSizeIndex];
        s := aRanges[0];
        curSizes := Integer(aRanges.Objects[0]);
        for i := 1 to Pred(aRanges.Count) do
        begin
          if Assigned(aProgress) then
          begin
            if aProgress.Terminated then
              Break;
            aProgress.Tick;
          end;
          if Integer(aRanges.Objects[i]) = MainSizeIndex then
            Continue;
          if Integer(aRanges.Objects[i]) <> curSizes then
          begin
            if curSizes <> MainSizeIndex then
            begin
              try
                v := WorkSheet.Range[s];
                v.RowHeight := Sizes[curSizes];
              except
              end;
            end;
            curSizes := Integer(aRanges.Objects[i]);
            s := aRanges[i];
          end
          else if Length(s) + Length(aRanges[i]) + 1 > 255 then
          begin
            try
              v := WorkSheet.Range[s];
              v.RowHeight := Sizes[curSizes];
            except
            end;
            s := aRanges[i];
          end
          else s := s + ';' + aRanges[i]
        end;
        if Length(s) > 0 then
        begin
          try
            v := WorkSheet.Range[s].Rows;
            v.RowHeight := Sizes[curSizes];
          except
          end;
        end;
      end;
  end;
end;

procedure TfrxExcel.ApplyStyles(aRanges: TStrings; Kind: byte; aProgress: TfrxProgress);
// Kind=0 - Styles
// Kind=1 - Frames
// Kind=2 - Merge
var
  i: integer;
  s: string;
  curStyle: integer;
begin
  if aRanges.Count > 0 then
  begin
    if Assigned(aProgress) then
      if not aProgress.Terminated then
      begin
        aProgress.Execute(aRanges.Count, frxResources.Get('ProgressStyles') + ' - ' + IntToStr(Kind + 1), True, True);
        s := aRanges[0];
        curStyle := Integer(aRanges.Objects[0]);
        for i := 1 to Pred(aRanges.Count) do
        begin
         if Assigned(aProgress) then
         begin
           if aProgress.Terminated then
             Break;
           aProgress.Tick;
         end;
         if Integer(aRanges.Objects[i]) <> CurStyle then
         begin
           case Kind of
             0: ApplyStyle(s, CurStyle);
             1: ApplyFrame(s, CurStyle);
          end;
          CurStyle := Integer(aRanges.Objects[i]);
          s := aRanges[i];
         end
         else if Length(s) + Length(aRanges[i]) + 1 > 255 then
         begin
           case Kind of
             0: ApplyStyle(s, CurStyle);
             1: ApplyFrame(s, CurStyle);
             2: try
                  WorkSheet.Range[s].MergeCells := True;
                except
                end;
          end;
          s := aRanges[i];
         end
         else s := s + ListSeparator + aRanges[i]
        end;
        case Kind of
          0: ApplyStyle(s, CurStyle);
          1: ApplyFrame(s, CurStyle);
          2: try
               WorkSheet.Range[s].MergeCells := True;
             except
             end;
        end;
      end
  end;
end;

procedure TfrxExcel.ApplyStyle(const RangeCoord: String; aStyle: Integer);
begin
  try
    if Length(RangeCoord) > 0 then
      WorkSheet.Range[RangeCoord].Style := 'S' + IntToStr(aStyle)
  except
  end;
end;

function TfrxExcel.ByteToFrameTypes(Value: Byte): TfrxFrameTypes;
begin
  Result := PFrameTypes(@Value)^
end;

procedure TfrxExcel.ApplyFrame(const RangeCoord: String; aFrame: Byte);
var
  vFrame: TfrxFrameTypes;
  vBorders: Variant;
begin
  try
    if aFrame <> 0 then
      if Length(RangeCoord) > 0 then
      begin
        vFrame := ByteToFrameTypes(aFrame);
        vBorders := WorkSheet.Range[RangeCoord].Cells.Borders;
        if ftLeft in vFrame then
          vBorders.Item[xlEdgeLeft].Linestyle := xlSolid;
        if ftRight in vFrame then
          vBorders.Item[xlEdgeRight].Linestyle := xlSolid;
        if ftTop in vFrame then
          vBorders.Item[xlEdgeTop].Linestyle := xlSolid;
        if ftBottom in vFrame then
          vBorders.Item[xlEdgeBottom].Linestyle := xlSolid;
      end;
  except
  end;
end;

procedure TfrxExcel.SetCellFrame(Frame: TfrxFrameTypes);
begin
  if ftLeft in Frame then
    Range.Cells.Borders.Item[xlEdgeLeft].Linestyle := xlSolid;
  if ftRight in Frame then
    Range.Cells.Borders.Item[xlEdgeRight].Linestyle := xlSolid;
  if ftTop in Frame then
    Range.Borders.Item[xlEdgeTop].Linestyle := xlSolid;
  if ftBottom in Frame then
    Range.Borders.Item[xlEdgeBottom].Linestyle := xlSolid;
end;

{ TfrxXLSExportDialog }

procedure TfrxXLSExportDialog.FormCreate(Sender: TObject);
begin
  frxResources.LocalizeForm(Self);
end;

procedure TfrxXLSExportDialog.PageNumbersEChange(Sender: TObject);
begin
  PageNumbersRB.Checked := True;
end;

end.