frxexportxls.pas

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

  ArrData: PArrData;
  j: Integer;
  FixRow: String;
  CurRowSize: Integer;
  CurRangeCoord: String;
  vRowsToSizes: TStrings;
  vCellStyles: TStrings;
  vCellFrames: TStrings;
  vCellMerges: TStrings;
  vCellFormats: TStringList;

  function ConvertFormat(const fstr: string): string;
  var
    i, err, p : integer;
    s: string;
  begin
    result := '';
    if length(fstr)>0 then
    begin
      p := pos('.', fstr);
      if p > 0 then
      begin
        s := Copy(fstr, p + 1, length(fstr) - p - 1);
        val(s, p ,err);
      end;
      case fstr[length(fstr)] of
        'n': begin
              result := '# ##0' + DecimalSeparator;
              for i := 1 to p do result := result + '0';
             end;
        'f': begin
               result := '0' + DecimalSeparator;
               for i := 1 to p do result := result + '0';
             end;
        'd': begin
               result := '#' + DecimalSeparator;
               for i := 1 to p do result := result + '#';
             end;
      end;
    end;
  end;

  procedure AlignFR2AlignExcel(HAlign: TfrxHAlign; VAlign: TfrxVAlign; var AlignH, AlignV: integer);
  begin
    if HAlign = haLeft then
      AlignH := xlLeft
    else if HAlign = haRight then
      AlignH := xlRight
    else if HAlign = haCenter then
      AlignH := xlCenter
    else if HAlign = haBlock then
      AlignH := xlJustify
    else
      AlignH := xlLeft;

    if VAlign = vaTop then
      AlignV := xlTop
    else if VAlign = vaBottom then
      AlignV := xlBottom
    else if VAlign = vaCenter then
      AlignV := xlCenter
    else
      AlignV := xlTop;
  end;

  function RoundSizeY(const Value: Extended; xlSizeYRound: Currency): Currency;
  begin
    Result := Round(Value / xlSizeYRound) * xlSizeYRound
  end;

  function GetSizeIndex(const aSize: Currency): integer;
  var
    i: integer;
    c: integer;
  begin
    c := Length(RowSizes);
    for i := 0 to c - 1 do
    begin
      if RowSizes[i] = aSize then
      begin
        Result := i;
        RowSizesCount[i] := RowSizesCount[i] + 1;
        Exit
      end;
    end;
    SetLength(RowSizes, c + 1);
    SetLength(RowSizesCount,c + 1);
    RowSizes[c] := aSize;
    RowSizesCount[c] := 1;
    Result := c
  end;

begin
  PicCount := 0;
  FExcel.SetPageMargin(FPageLeft, FPageRight, FPageTop, FPageBottom, FPageOrientation);

  if ShowProgress then
  begin
    FProgress := TfrxProgress.Create(self);
    FProgress.Execute(FMatrix.Height - 1, frxResources.Get('ProgressRows') + ' - 1', True, True);
  end;

  PBreakCounter := 0;

  FixRow := 'A1';
  CurRowSize := 0;
  vRowsToSizes := TStringList.Create;
  try
    vRowsToSizes.Capacity := FMatrix.Height;
    imc := 0;
    for y := 1 to FMatrix.Height - 1 do
    begin
      if ShowProgress then
      begin
       if FProgress.Terminated then
         break;
       FProgress.Tick;
      end;

      if (FMatrix.GetCellYPos(y) >= FMatrix.GetPageBreak(PBreakCounter)) and FpageBreaks then
      begin
        FExcel.WorkSheet.Rows[y + 2].PageBreak := xlPageBreakManual;
        Inc(PBreakCounter);
      end;

      drow := (FMatrix.GetYPosById(y) - FMatrix.GetYPosById(y - 1)) / Ydivider;
      j := GetSizeIndex(RoundSizeY(drow, xlSizeYRound));
      if RowSizesCount[j] > RowSizesCount[imc] then
        imc := j;
      if y > 1 then
      begin
        if j <> CurRowSize then
        begin
          if FixRow <> 'A' + IntToStr(y - 1) then
            CurRangeCoord := FixRow + ':A' + IntToStr(y - 1)
          else
            CurRangeCoord := FixRow;
          i := GetNewIndex(vRowsToSizes, CurRowSize);
          vRowsToSizes.InsertObject(i, CurRangeCoord, TObject(CurRowSize));
          FixRow := 'A' + IntToStr(y);
          CurRowSize := j;
        end;
      end;
      if y = FMatrix.Height - 1 then
      begin
        CurRangeCoord := FixRow + ':A' + IntToStr(y);
        i := GetNewIndex(vRowsToSizes, j);
        vRowsToSizes.InsertObject(i, CurRangeCoord, TObject(j));
      end;
    end;
    FExcel.SetRowsSize(vRowsToSizes, RowSizes, imc, FMatrix.Height, FProgress)
  finally
    vRowsToSizes.Free;
  end;

  if ShowProgress then
    if not FProgress.Terminated then
      FProgress.Execute(FMatrix.Width - 1, frxResources.Get('ProgressColumns'), True, True);

  for x := 1 to FMatrix.Width - 1 do
  begin
    if ShowProgress then
    begin
      if FProgress.Terminated then
        break;
      FProgress.Tick;
    end;
    dcol := (FMatrix.GetXPosById(x) - FMatrix.GetXPosById(x - 1)) / Xdivider;
    FExcel.SetColSize(x, dcol);
  end;

  if ShowProgress then
    if not FProgress.Terminated then
      FProgress.Execute(FMatrix.StylesCount - 1, frxResources.Get('ProgressStyles'), True, True);

  for x := 0 to FMatrix.StylesCount - 1 do
  begin
    if ShowProgress then
    begin
      if FProgress.Terminated then break;
      FProgress.Tick;
    end;
    EStyle := FMatrix.GetStyleById(x);
    s := 'S' + IntToStr(x);
    XStyle := FExcel.Excel.ActiveWorkbook.Styles.Add(s);
    XStyle.Font.Bold := fsBold in EStyle.Font.Style;
    XStyle.Font.Italic := fsItalic in EStyle.Font.Style;
    XStyle.Font.Underline := fsUnderline in EStyle.Font.Style;;
    XStyle.Font.Name := EStyle.Font.Name;
    XStyle.Font.Size := EStyle.Font.Size;
    XStyle.Font.Color:= ColorToRGB(EStyle.Font.Color);
    if (EStyle.Color <> clWhite) and (EStyle.Color <> clNone) then 
      XStyle.Interior.Color := ColorToRGB(EStyle.Color);
    if (EStyle.Rotation > 0) and (EStyle.Rotation <= 90) then
      XStyle.Orientation := EStyle.Rotation
    else
      if (EStyle.Rotation < 360) and (EStyle.Rotation >= 270) then
        XStyle.Orientation := EStyle.Rotation - 360;

    AlignFR2AlignExcel(EStyle.HAlign, EStyle.VAlign, Horiz, Vert);
    XStyle.VerticalAlignment := Vert;
    XStyle.HorizontalAlignment := Horiz;
    Application.ProcessMessages;
  end;
  ExlArray := VarArrayCreate([1, FMatrix.Height , 1, FMatrix.Width ], varVariant);
  if ShowProgress then
    if not FProgress.Terminated then
      FProgress.Execute(FMatrix.Height, frxResources.Get('ProgressObjects'), True, True);
  ArrData := VarArrayLock(ExlArray) ;
  vCellStyles := TStringList.Create;
  vCellFrames := TStringList.Create;
  vCellMerges := TStringList.Create;
  vCellFormats := TStringList.Create;
  try
    for y := 1 to FMatrix.Height do
    begin
      if ShowProgress then
      begin
        if FProgress.Terminated then
          Break;
        FProgress.Tick;
      end;
      for x := 1 to FMatrix.Width do
      begin
        i := FMatrix.GetCell(x - 1, y - 1);
        if i <> -1 then
        begin
          Obj := FMatrix.GetObjectById(i);
          if Obj.Counter = 0 then
          begin
            Obj.Counter := 1;
            FMatrix.GetObjectPos(i, fx, fy, dx, dy);
            with FExcel do
            if  (dx > 1) or (dy > 1) then
              CurRangeCoord := IntToCoord(x, y)+ ':' +
                IntToCoord(x + dx - 1, y + dy - 1)
            else
              CurRangeCoord := IntToCoord(x, y);
            if FExportStyles then
            begin
              j := GetNewIndex(vCellStyles, Obj.StyleIndex);
              vCellStyles.InsertObject(j, CurRangeCoord, TObject(Obj.StyleIndex));
            end;

            if FMergeCells then
              if (dx > 1) or (dy > 1) then
                vCellMerges.Add(CurRangeCoord);
            if FExportStyles then
            begin
              i := FrameTypesToByte(obj.Style.FrameTyp);
              if i <> 0 then
              begin
                j := GetNewIndex(vCellFrames, i);
                vCellFrames.InsertObject(j, CurRangeCoord, TObject(i));
              end;
            end;

            s := CleanReturns(Obj.Memo.Text);
            if Length(s) > XLMaxChars then
              s := Copy(s, 1, XLMaxChars);

            if not FAsText then
              if (Obj.Style.DisplayFormat.Kind = fkNumeric) then
              begin
                if length(s) > 0 then
                  begin
                  s := StringReplace(s, ThousandSeparator, '', [rfReplaceAll]);
                  if Obj.Style.DisplayFormat.DecimalSeparator <> '' then
                    s := StringReplace(s, Obj.Style.DisplayFormat.DecimalSeparator, '.', [rfReplaceAll])
                  else
                    s := StringReplace(s, DecimalSeparator, '.', [rfReplaceAll]);
                  if (Obj.Style.DisplayFormat.FormatStr <> '') then
                    vCellFormats.Add(ConVertFormat(Obj.Style.DisplayFormat.FormatStr) +
                      '=' + FExcel.IntToCoord(x, y))
                end
              end
              else
                if (Obj.Style.DisplayFormat.Kind = fkText) then
                  s := '''' + s;

            if FAsText then
              s := '''' + s;
            ArrData^[y + FMatrix.Height * (x - 1)] := s;
            if (not Obj.IsText) and ((Obj.Image <> nil) or (Obj.Metafile.Width > 0)) then
            begin
              FExcel.SetRange(x, y, dx, dy);
              Inc(PicCount);
              if FExportEMF then
                Obj.Metafile.SaveToClipboardFormat(PicFormat, PicData, PicPalette)
              else
              begin
                Pic := TPicture.Create;
                try
                  Pic.Bitmap.Assign(Obj.Image);
                  Pic.SaveToClipboardFormat(PicFormat, PicData, PicPalette);
                finally
                  Pic.Free;
                end;
              end;
              Clipboard.SetAsHandle(PicFormat,THandle(PicData));
              FExcel.Range.PasteSpecial(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
              FExcel.WorkSheet.Pictures[PicCount].Left := FExcel.WorkSheet.Pictures[PicCount].Left + 1;
              FExcel.WorkSheet.Pictures[PicCount].Top := FExcel.WorkSheet.Pictures[PicCount].Top + 1;
              FExcel.WorkSheet.Pictures[PicCount].Width := Obj.Width / 1.38;
              FExcel.WorkSheet.Pictures[PicCount].Height := Obj.Height/ 1.38;
            end;
          end;
        end;
      end;
    end;

    if FExportStyles then
    begin
      FExcel.ApplyStyles(vCellStyles, 0, FProgress);
      FExcel.ApplyStyles(vCellFrames, 1, FProgress);
      FExcel.ApplyFormats(vCellFormats, FProgress);
    end;
    if FMergeCells then
      FExcel.ApplyStyles(vCellMerges, 2, FProgress);
  finally
    VarArrayUnlock(ExlArray);
    vCellStyles.Free;
    vCellFrames.Free;
    vCellMerges.Free;
    vCellFormats.Free;
  end;
  FExcel.SetRange(1, 1, FMatrix.Width , FMatrix.Height);
  FExcel.Range.Value := ExlArray;
  FExcel.WorkSheet.Cells.WrapText := True;
  if ShowProgress then
    FProgress.Free;
end;

function TfrxXLSExport.ShowModal: TModalResult;
begin
  with TfrxXLSExportDialog.Create(nil) do
  begin
    OpenExcelCB.Visible := not SlaveExport;
    if OverwritePrompt then
      SaveDialog1.Options := SaveDialog1.Options + [ofOverwritePrompt];
    if SlaveExport then
      FOpenExcelAfterExport := False;

    if (FileName = '') and (not SlaveExport) then
      SaveDialog1.FileName := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), SaveDialog1.DefaultExt)
    else
      SaveDialog1.FileName := FileName;

    ContinuousCB.Checked := (not EmptyLines) or SuppressPageHeadersFooters;
    PicturesCB.Checked := FExportPictures;
    MergeCB.Checked := FMergeCells;
    WCB.Checked := FWysiwyg;
    OpenExcelCB.Checked := FOpenExcelAfterExport;
    AsTextCB.Checked := FAsText;
    BackgrCB.Checked := FBackground;
    FastExpCB.Checked := FFastExport;
    PageBreaksCB.Checked := FpageBreaks;

    if PageNumbers <> '' then
    begin
      PageNumbersE.Text := PageNumbers;
      PageNumbersRB.Checked := True;
    end;

    Result := ShowModal;
    if Result = mrOk then
    begin
      PageNumbers := '';
      CurPage := False;
      if CurPageRB.Checked then
        CurPage := True
      else if PageNumbersRB.Checked then
        PageNumbers := PageNumbersE.Text;

      FMergeCells := MergeCB.Checked;
      FPageBreaks :=  PageBreaksCB.Checked;
      FExportPictures := PicturesCB.Checked;
      EmptyLines := not ContinuousCB.Checked;
      SuppressPageHeadersFooters := ContinuousCB.Checked;
      FWysiwyg := WCB.Checked;
      FOpenExcelAfterExport := OpenExcelCB.Checked;
      FAsText := AsTextCB.Checked;
      FBackground := BackgrCB.Checked;
      FFastExport := FastExpCB.Checked;

      if not SlaveExport then
      begin
        if DefaultPath <> '' then
          SaveDialog1.InitialDir := DefaultPath;
        if SaveDialog1.Execute then
          FileName := SaveDialog1.FileName
        else
          Result := mrCancel;
      end
    end;
    Free;
  end;
end;

function TfrxXLSExport.Start: Boolean;
begin
  if SlaveExport then
  begin
    if Report.FileName <> '' then
      FileName := ChangeFileExt(GetTemporaryFolder + ExtractFileName(Report.FileName), frxGet(8010))
    else
      FileName := ChangeFileExt(GetTempFile, frxGet(8010))
  end;
  Result := False;
  if FileName <> '' then
  begin
    if (ExtractFilePath(FileName) = '') and (DefaultPath <> '') then
      if DefaultPath[Length(DefaultPath)] = '\' then
        FileName := DefaultPath + FileName
      else
        FileName := DefaultPath + '\' + FileName;
    FFirstPage := True;
    FMatrix := TfrxIEMatrix.Create(UseFileCache, Report.EngineOptions.TempDir);
    FMatrix.DotMatrix := Report.DotMatrixReport;
    FMatrix.ShowProgress := ShowProgress;
    FMatrix.MaxCellHeight := XLMaxHeight * Ydivider;
    FMatrix.BackgroundImage := False;
    FMatrix.Background := FBackground and FEmptyLines;
    FMatrix.RichText := not FExportEMF;
    FMatrix.PlainRich := not FExportEMF;
    if FWysiwyg then
      FMatrix.Inaccuracy := 0.5
    else
      FMatrix.Inaccuracy := 10;
    FMatrix.RotatedAsImage := False;
    FMatrix.DeleteHTMLTags := True;
    FMatrix.Printable := ExportNotPrintable;
    FMatrix.EmptyLines := FEmptyLines;
    FMatrix.EMFPictures := FExportEMF;
    try
      FExcel := TfrxExcel.Create;
      FExcel.OpenExcel;
      Result := True;
    except
      on E: Exception do
      begin
        FExcel.Free;
        MessageDlg('Microsoft Excel must be installed on this computer!', mtError, [mbOk], 0);
      end;
    end;
  end;
end;

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

procedure TfrxXLSExport.ExportObject(Obj: TfrxComponent);
begin
  if Obj.Page <> nil then
    Obj.Page.Top := FMatrix.Inaccuracy;
  if Obj.Name = '_pagebackground' then
    Exit;
  if (Obj is TfrxView) and (ExportNotPrintable or TfrxView(Obj).Printable) then
    if (Obj is TfrxCustomMemoView) or