frxexportxls.pas

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

      (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
        if ExtractFilePath(FileName) = '' then
          FileName := GetCurrentDir + '\' + FileName;
        FExcel.WorkBook.SaveAs(FileName, xlNormal, EmptyParam,
          EmptyParam, EmptyParam, EmptyParam, xlNoChange, EmptyParam, EmptyParam, EmptyParam);
      finally
        FExcel.Excel.Application.DisplayAlerts := True;
        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;
  OleInitialize(nil);
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;
    Excel.Application.DisplayAlerts := 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);
      end;

    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;

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
        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;

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;

procedure TfrxExcel.ApplyFormats(aRanges: TStringlist; aProgress: TfrxProgress);
var
  i: integer;
  s: string;
  curFormat: string;

  function ValueFrom(List: TStringList; Index: Integer): String;
  begin
    if Index >= 0 then
      Result := Copy(List[Index], Length(List.Names[Index]) + 2, MaxInt) else
      Result := '';
  end;

begin
  if aRanges.Count > 0 then
  begin
    if Assigned(aProgress) then
      aProgress.Execute(aRanges.Count, 'Data formats', True, True);
    s := ValueFrom(aRanges, 0);
    curFormat := aRanges.Names[0];
    for i := 1 to Pred(aRanges.Count) do
    begin
      if Assigned(aProgress) then
      begin
        if aProgress.Terminated then
          Break;
        aProgress.Tick;
      end;
      if aRanges.Names[i] <> CurFormat then
      begin
        ApplyFormat(s, CurFormat);
        CurFormat := aRanges.Names[i];
        s := ValueFrom(aRanges, i);
      end
      else
      if Length(s) + Length(ValueFrom(aRanges, i)) + 1 > 255 then
      begin
        ApplyFormat(s, CurFormat);
        s := ValueFrom(aRanges, i);
      end
      else
        s := s + ListSeparator + ValueFrom(aRanges, i)
    end;
      ApplyFormat(s, CurFormat);
  end;
end;

procedure TfrxExcel.ApplyFormat(const RangeCoord, aFormat: String);
begin
  if Length(RangeCoord) > 0 then
  try
    WorkSheet.Range[RangeCoord].NumberFormat := aFormat;
  except
  end;
end;

destructor TfrxExcel.Destroy;
begin
  OleUnInitialize;
  inherited;
end;

{ TfrxXLSExportDialog }

procedure TfrxXLSExportDialog.FormCreate(Sender: TObject);
begin
  Caption := frxGet(8000);
  OkB.Caption := frxGet(1);
  CancelB.Caption := frxGet(2);
  GroupPageRange.Caption := frxGet(7);
  AllRB.Caption := frxGet(3);
  CurPageRB.Caption := frxGet(4);
  PageNumbersRB.Caption := frxGet(5);
  DescrL.Caption := frxGet(9);
  GroupQuality.Caption := frxGet(8);
  ContinuousCB.Caption := frxGet(8950);
  PicturesCB.Caption := frxGet(8002);
  MergeCB.Caption := frxGet(8003);
  PageBreaksCB.Caption := frxGet(6);
  FastExpCB.Caption := frxGet(8004);
  WCB.Caption := frxGet(8005);
  AsTextCB.Caption := frxGet(8006);
  BackgrCB.Caption := frxGet(8007);
  OpenExcelCB.Caption := frxGet(8008);
  SaveDialog1.Filter := frxGet(8009);
  SaveDialog1.DefaultExt := frxGet(8010);

  if UseRightToLeftAlignment then
    FlipChildren(True);
end;

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

procedure TfrxXLSExportDialog.PageNumbersEKeyPress(Sender: TObject;
  var Key: Char);
begin
  case key of
    '0'..'9':;
    #8, '-', ',':;
  else
    key := #0;
  end;
end;

procedure TfrxXLSExportDialog.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_F1 then
    frxResources.Help(Self);
end;

end.