froleexl.pas

不错的报表工具

          end;
          dy := mi - c - 1;
          break;
       end;
     ObjPosAdd(ObjectPos, fx, fy, dx, dy, obj);
   end;
end;

{$WARNINGS OFF}
procedure TfrOLEExcelExport.ExportPage;
var
  i, j, k, l, x, y, dx, dy : integer;
  x1, y1, dx1, dy1, olddx, olddy : integer;
  dcol, drow, delta, conv : Extended;
  s : string;
  Left, Right, Top, Bottom : Extended;
  Orient, Vert, Horiz: integer;
  m: TRect;
  obj: TfrMemoView;
  PicObj: TfrPictureView;
  ExlArray: Variant;
  TimeBegin, TimeRemain, TimeEstimate: TDateTime;
  Step: integer;
  defaultV, defaultH: integer;

  oldxFN, oldyFN: integer;
  oldFN: string;
  oldxFS, oldyFS: integer;
  oldFS: integer;
  oldxFSt, oldyFSt: integer;
  oldFSt: TFontStyles;
  oldxAH, oldyAH: integer;
  oldAH: integer;
  oldxAV, oldyAV: integer;
  oldAV: integer;
  oldxFC, oldyFC: integer;
  oldFC: integer;
  oldxFR, oldyFR: integer;
  oldFR: integer;
  oldxC, oldyC: integer;
  oldC: integer;

  procedure AlignFR2AlignExcel(Align: integer; var AlignH, AlignV: integer);
  begin
    if (Align and frtaRight) <> 0 then
         if (Align and frtaCenter) <> 0 then AlignH := xlJustify
         else AlignH := xlRight
      else if (Align and frtaCenter) <> 0 then AlignH := xlCenter
      else AlignH := xlLeft;
    if (Align and frtaMiddle) <> 0 then AlignV := xlCenter
      else if (Align and frtaDown) <> 0 then AlignV := xlBottom
      else AlignV := xlTop;
  end;

  procedure SetRegionAttrib(x1, y1, x2, y2: integer; Attr: variant; Attr2:TfontStyles; func: integer);
   var
     dx, dy: integer;
     procedure CallFunc(param: variant; param2: TfontStyles; numb: integer);
     begin
       case numb of
         1 : Excel.SetCellFontStyle(param2);
         2 : Excel.SetCellFontSize(param);
         3 : Excel.SetCellFontName(param);
         4 : Excel.SetCellHAlign(param);
         5 : Excel.SetCellVAlign(param);
         6 : Excel.SetCellFontColor(param);
         7 : begin
               Excel.SetCellFrame(param);
               if (dx > 1) and (param > 0) then
                 Excel.SetCellFrameInsideH;
               if (dy > 1) and (param > 0) then
                 Excel.SetCellFrameInsideV;
             end;
         8 : Excel.SetCellFillColor(param);
       end;
     end;
  begin
      if y2 > y1 then
      begin
        dx := RX.Count - x1; dy := 1;
        Excel.SetRange(x1, y1, dx, dy);
        CallFunc(Attr, Attr2, func);
        if y2 - y1 > 1 then
        begin
          dx := RX.Count - 1; dy := y2 - 1;
          Excel.SetRange(1, y1 + 1, dx, dy);
          CallFunc(Attr, Attr2, func);
        end;
        dx := x2 - 1; dy := 1;
        Excel.SetRange(1, y2, dx, dy);
        CallFunc(Attr, Attr2, func);
      end
      else
      begin
        dx := x2 - x1; dy := 1;
        Excel.SetRange(x1, y2, dx, dy);
        CallFunc(Attr, Attr2, func);
      end;
  end;

begin
  TimeBegin := Time;
  Step := 0;
  TimeRemain := 0;

  if CurReport.EMFPages[CurrentPage - 1].pgor = poLandscape then Orient := 2
    else Orient := 1;
  m := CurReport.EMFPages[CurrentPage - 1].pgMargins;
  Left := m.Left / 4;
  Right := m.Right / 4;
  Top := m.Top / 4;
  Bottom := m.Bottom / 4;
  Excel.SetPageMargin(Left, Right, Top, Bottom, Orient);

  i := 0;
  CurReport.Terminated := false;
  for y := 1 to RY.Count - 1 do
  begin
     frProgressForm.Label1.Caption := frLoadStr(frRes + 1865) + IntToStr(y);
     frProgressForm.Label1.Refresh;
     drow := expScaleY * (TObjCell(RY[y]).Value - TObjCell(RY[y - 1]).Value) / Ydivider;
     Excel.SetRowSize(y + cury, drow);
     if pgBreakList.Count > i then
     if (pgBreakList[i] = IntToStr(TObjCell(RY[y]).Value)) and expPageBreaks then
     begin
       Excel.WorkSheet.Rows[y + 2].PageBreak := xlPageBreakManual;
       inc(i);
     end;
  end;

  for x := 1 to RX.Count - 1 do
  begin
     frProgressForm.Label1.Caption := frLoadStr(frRes + 1866) + IntToStr(x);
     frProgressForm.Label1.Refresh;
     dcol := expScaleX*(TObjCell(RX[x]).Value - TObjCell(RX[x - 1]).Value) / Xdivider;
     Excel.SetColSize(x, dcol);
  end;

  ExlArray := VarArrayCreate([0,RY.Count - 1, 0,RX.Count - 1], varVariant);

  oldxFN := 1; oldyFN := CurY + 1;
  oldFN := '';
  oldxFC := 1; oldyFC := CurY + 1;
  oldFC := clBlack;
  oldxFS := 1; oldyFS := CurY + 1;
  oldFS := 10;
  oldxFSt := 1; oldyFSt := CurY + 1;
  oldFSt := [];
  oldxAH := 1; oldyAH := CurY + 1;
  oldAH:=xlLeft;
  oldxAV := 1; oldyAV := CurY + 1;
  oldAV := xlTop;
  oldxFR := 1; oldyFR := CurY + 1;
  oldFR := 0;
  oldxC := 1; oldyC := CurY + 1;
  oldC := clNone;

  for i := 0 to ObjectPos.Count - 1 do
  begin
    frProgressForm.Label1.Caption := frLoadStr(frRes + 1841) + IntToStr(Step) + frLoadStr(frRes + 1842) + TimeToStr(TimeRemain);
    frProgressForm.Label1.Refresh;

    x := TObjPos(ObjectPos[i]).x + 1;
    y := TObjPos(ObjectPos[i]).y + CurY + 1;
    dx := TObjPos(ObjectPos[i]).dx;
    dy := TObjPos(ObjectPos[i]).dy;
    Excel.SetRange(x, y, dx, dy);

    if TfrView(PageObj[TObjPos(ObjectPos[i]).obj]) is TfrMemoView then
    begin
        Obj := TfrMemoView(PageObj[TObjPos(ObjectPos[i]).obj]);
        s:=CleanReturns(Obj.Memo.Text);
        l:=pos('.', s);
        if l>0 then
        begin
          s[l]:=',';
{$IFDEF Delphi6}
          if TryStrToFloat(s, conv) then
            Excel.Range.Cells.NumberFormat := '@';
{$ENDIF}
        end;
        AlignFR2AlignExcel(Obj.Alignment, Horiz, Vert);
        if expBorders then
          Excel.SetCellFrame(Obj.FrameTyp);
        if expFillColor then
          if Obj.FillColor <> clNone then
            Excel.SetCellFillColor(Obj.FillColor);
        if (Obj.Alignment and $4) <>0 then
          Excel.SetCellOrientation(90);
        if expMerged then
          if (dx > 1) or (dy > 1) then  
          begin
            olddx := dx; olddy := dy;
            for j:=i+1 to ObjectPos.Count - 1 do
            begin
              x1 := TObjPos(ObjectPos[j]).x + 1;
              y1 := TObjPos(ObjectPos[j]).y + CurY + 1;
              if ((y + dy) > y1) and ((x + dx) > x1) and (x <= x1) then
              begin
                if y = y1 then
                begin
                  if (x + dx) > x1 then dx := x1 - x;
                  dy:=1
                end
                else
                  dy := y1 - y;
              end;
            end;
            if (dx > 1) or (dy > 1) then
            begin
              if (dx <> olddx) or (dy <> olddy) then
                Excel.SetRange(x, y, dx, dy);
              Excel.MergeCells;
            end;
          end;

        if (Obj.Font.Style <> OldFSt) and expFontStyle then
        begin
          SetRegionAttrib(OldxFSt, OldyFSt, x, y, 0, OldFSt, 1);
          OldxFSt := x; OldYFSt := y;
          OldFSt := Obj.Font.Style;
        end;
        if (Obj.Font.Size <> OldFS) and expFontSize then
        begin
          SetRegionAttrib(OldxFS, OldyFS, x, y, OldFS, [], 2);
          OldxFS := x; OldYFS := y;
          OldFS := Obj.Font.Size;
        end;
        if (Obj.Font.Name <> OldFN) and expFontName then
        begin
          SetRegionAttrib(OldxFN, OldyFN, x, y, OldFN, [], 3);
          OldxFN := x; OldYFN := y;
          OldFN := Obj.Font.Name;
        end;
        if expAlign then
        begin
          if Horiz <> OldAH then
          begin
            SetRegionAttrib(OldxAH, OldyAH, x, y, OldAH, [], 4);
            OldxAH := x; OldyAH := y;
            OldAH := Horiz;
          end;
          if Vert <> OldAV then
          begin
            SetRegionAttrib(OldxAV, OldyAV, x, y, OldAV, [], 5);
            OldxAV := x; OldyAV := y;
            OldAV := Vert;
          end;
        end;
        if (Obj.Font.Color <> OldFC) and expFontColor then
        begin
          SetRegionAttrib(OldxFC, OldyFC, x, y, OldFC, [], 6);
          OldxFC := x; OldYFC := y;
          OldFC := Obj.Font.Color;
        end;
        s := CleanReturns(Obj.Memo.Text);
        ExlArray[y-1-CurY, x-1] := s;
    end
    else
    if TfrView(PageObj[TObjPos(ObjectPos[i]).obj]) is TfrPictureView then
    begin
       Inc(CntPics);
       PicObj := TfrPictureView(PageObj[TObjPos(ObjectPos[i]).obj]);
{$IFDEF Delphi3}
       PicObj.Picture.SaveToClipboardFormat(PicFormat, THandle(PicData), HPALETTE(PicPalette));
{$ELSE}
       PicObj.Picture.SaveToClipboardFormat(PicFormat, PicData, PicPalette);
{$ENDIF}

       Clipboard.SetAsHandle(PicFormat,THandle(PicData));
{$IFDEF Delphi3}
       Excel.Range.PasteSpecial;
{$ELSE}
       Excel.Range.PasteSpecial(EmptyParam, EmptyParam, EmptyParam, EmptyParam);
{$ENDIF}
       Excel.WorkSheet.Pictures[CntPics].Width := PicObj.dx / 1.5;
       Excel.WorkSheet.Pictures[CntPics].Height := PicObj.dy / 1.5;
    end;

    inc(Step);
    TimeEstimate := TimeBegin + (ObjectPos.Count - 1) * (Time - TimeBegin) / Step;
    TimeRemain := TimeEstimate - Time;

    Application.ProcessMessages;

    if CurReport.Terminated then break;

  end;
  x := x + dx; y := y + dy;
  SetRegionAttrib(OldxFSt, OldyFSt, x, y, 0, OldFSt, 1);
  SetRegionAttrib(OldxFS, OldyFS, x, y, OldFS, [], 2);
  SetRegionAttrib(OldxFN, OldyFN, x, y, OldFN, [], 3);
  SetRegionAttrib(OldxAH, OldyAH, x, y, OldAH, [], 4);
  SetRegionAttrib(OldxAV, OldyAV, x, y, OldAV, [], 5);
  SetRegionAttrib(OldxFC, OldyFC, x, y, OldFC, [], 6);

  Excel.SetRange(1, CurY + 1, RX.Count - 1, RY.Count - 1);
  Excel.Range.Value := ExlArray;
  CurY := Y - 1;
end;
{$WARNINGS ON}

function TfrOLEExcelExport.ShowModal: Word;

var
  PageNumbers: string;

  procedure ParsePageNumbers;
  var
    i, j, n1, n2: Integer;
    s: String;
    IsRange: Boolean;
  begin
    s := PageNumbers;
    while Pos(' ', s) <> 0 do
      Delete(s, Pos(' ', s), 1);
    if s = '' then Exit;
    s := s + ',';
    i := 1; j := 1; n1 := 1;
    IsRange := False;
    while i <= Length(s) do
    begin
      if s[i] = ',' then
      begin
        n2 := StrToInt(Copy(s, j, i - j));
        j := i + 1;
        if IsRange then
          while n1 <= n2 do
          begin
            pgList.Add(IntToStr(n1));
            Inc(n1);
          end
        else
          pgList.Add(IntToStr(n2));
        IsRange := False;
      end
      else if s[i] = '-' then
      begin
        IsRange := True;
        n1 := StrToInt(Copy(s, j, i - j));
        j := i + 1;
      end;
      Inc(i);
    end;
  end;

begin
 if ShowDialog then
 begin
  frExportSet := TfrOLEExcelSet.Create(nil);
  frExportSet.CB_Merged.Checked := expMerged;
  frExportSet.CB_WrapWords.Checked := expWrapWords;
  frExportSet.CB_FillColor.Checked := expFillColor;
  frExportSet.CB_Borders.Checked := expBorders;
  frExportSet.CB_Align.Checked := expAlign;
  frExportSet.CB_PageBreaks.Checked := expPageBreaks;
  frExportSet.CB_FontName.Checked := expFontName;
  frExportSet.CB_FontSize.Checked := expFontSize;
  frExportSet.CB_FontStyle.Checked := expFontStyle;
  frExportSet.CB_FontColor.Checked := expFontColor;
  frExportSet.CB_Pictures.Checked := expPictures;
  frExportSet.CB_OpenExcel.Checked := expOpenAfter;
  frExportSet.E_ScaleX.Text := FloatToStr(Int(expScaleX*100));
  frExportSet.E_ScaleY.Text := FloatToStr(Int(expScaleY*100));
  frExportSet.E_TMargin.Text := FloatToStr(expTopMargin);
  frExportSet.E_LMargin.Text := FloatToStr(expLeftMargin);
  Result := frExportSet.ShowModal;
  PageNumbers := frExportSet.E_Range.Text;
  expMerged := frExportSet.CB_Merged.Checked;
  expWrapWords := frExportSet.CB_WrapWords.Checked;
  expFillColor := frExportSet.CB_FillColor.Checked;
  expBorders := frExportSet.CB_Borders.Checked;
  expAlign := frExportSet.CB_Align.Checked;
  expPageBreaks := frExportSet.CB_PageBreaks.Checked;
  expFontName := frExportSet.CB_FontName.Checked;
  expFontSize := frExportSet.CB_FontSize.Checked;
  expFontStyle := frExportSet.CB_FontStyle.Checked;
  expFontColor := frExportSet.CB_FontColor.Checked;
  expPictures := frExportSet.CB_Pictures.Checked;
  expOpenAfter := frExportSet.CB_OpenExcel.Checked;
  expScaleX := StrToInt(frExportSet.E_ScaleX.Text) / 100;
  expScaleY := StrToInt(frExportSet.E_ScaleY.Text) / 100;
  expTopMargin := StrToFloat(frExportSet.E_TMargin.Text);
  expLeftMargin := StrToFloat(frExportSet.E_LMargin.Text);
  frExportSet.Destroy;
 end
 else
   Result := mrOk;
 pgList.Clear;
 pgBreakList.Clear;
 ParsePageNumbers;
end;

procedure TfrOLEExcelExport.OnBeginDoc;
begin
  OnAfterExport := AfterExport;
  Excel.OpenExcel;