rm_e_xls.pas

进销存·完整的·有数据库的·非常完整·只得参考

  begin
    Result := Abs(v1 - v2) <= FExportPrecision;
  end;

  procedure _ExportText;
  var
    s: string;

    procedure _SetXLSBorders;

      procedure _SetXLSBorder(bi: cardinal; b: TRMEFFrameInfo);
      begin
        if not b.FrameVisible then exit;
        lRange.Borders[bi].Color := b.FrameColor;
        case TPenStyle(b.FrameStyle) of
          psSolid: lRange.Borders[bi].LineStyle := xlContinuous;
          psDash: lRange.Borders[bi].LineStyle := xlDash;
          psDot: lRange.Borders[bi].LineStyle := xlDot;
          psDashDot: lRange.Borders[bi].LineStyle := xlDashDot;
          psDashDotDot: lRange.Borders[bi].LineStyle := xlDashDotDot;
          psClear: lRange.Borders[bi].LineStyle := xlLineStyleNone;
          psInsideFrame: lRange.Borders[bi].LineStyle := xlLineStyleNone;
        end;
        lRange.Borders[bi].Weight := xlThin;
      end;

    begin
      _SetXLSBorder(xlEdgeLeft, liDataRec^.LFInfo);
      _SetXLSBorder(xlEdgeTop, liDataRec^.TFInfo);
      _SetXLSBorder(xlEdgeRight, liDataRec^.RFInfo);
      _SetXLSBorder(xlEdgeBottom, liDataRec^.BFInfo);
    end;

  begin
    if liDataRec^.BmpWidth > 0 then
    begin
      lRange.Value := '';
      Exit;
    end;

    s := liDataRec^.Text;
    Delete(s, Length(s) - 1, 2);
    lRange.Value := StringReplace(s, #13, '', [rfReplaceAll]);
    lRange.Font.Color := liDataRec^.FontInfo.Color;
    lRange.Font.Name := liDataRec^.FontInfo.Name;
    lRange.Font.Size := liDataRec^.FontInfo.Size;
    lRange.Font.Bold := fsBold in liDataRec^.FontInfo.Style;
    lRange.Font.Italic := fsItalic in liDataRec^.FontInfo.Style;
    lRange.Font.Underline := fsUnderline in liDataRec^.FontInfo.Style;
    lRange.Font.Strikethrough := fsStrikeOut in liDataRec^.FontInfo.Style;
//    lRange.Font.Charset := liDataRec^.FontInfo.Charset;
    if liDataRec^.WordWrap then
      lRange.WrapText := liDataRec^.WordWrap;
    _SetXLSBorders;
    if (liDataRec^.FrameInfo.FillColor <> clNone) and (liDataRec^.FrameInfo.FillColor <> clWhite) then
    begin
      lRange.Interior.Color := liDataRec^.FrameInfo.FillColor;
      lRange.Interior.Pattern := xlSolid;
    end;

    if eftpAlignBottom in liDataRec^.TextAlign then
      lRange.VerticalAlignment := xlVAlignBottom
    else if eftpAlignVerticalCenter in liDataRec^.TextAlign then
      lRange.VerticalAlignment := xlVAlignCenter;
//    else
//      lRange.VerticalAlignment := xlVAlignTop;

    if eftpAlignRight in liDataRec^.TextAlign then
      lRange.HorizontalAlignment := xlHAlignRight
    else if eftpAlignCenter in liDataRec^.TextAlign then
      lRange.HorizontalAlignment := xlHAlignCenter
    else
      lRange.HorizontalAlignment := xlHAlignLeft;
  end;

  procedure _ExportImage;
  var
    liFileName: string;
    TempDir: array[0..MAX_PATH] of char;
    TempFile: array[0..MAX_PATH] of char;
  begin
    if not ExportImages then Exit;
    if GetTempPath(sizeof(TempDir), TempDir) = 0 then Exit;
    if GetTempFileName(TempDir, 'rm', 0, TempFile) = 0 then Exit;
    liFileName := StrPas(TempFile);
    try
      liFileName := SaveBitmapAs(liDataRec^.Bitmap,
        ExportImageFormat{$IFDEF JPEG}, JPEGQuality{$ENDIF}, ChangeFileExt(liFileName, ''));
      lRange.Worksheet.Shapes.AddPicture(liFileName, false, true, lRange.Left, lRange.Top, lRange.Width, lRange.Height);
    finally
      DeleteFile(PChar(liFileName));
    end;
  end;

begin
  if (FpgList.Count <> 0) and (FpgList.IndexOf(IntToStr(FPageNo + 1)) < 0) then
  begin
    inherited OnEndPage;
    Exit;
  end;

	pe := TList.Create;
	for i := 0 to FDataList.Count - 1 do
  begin
		New(lItem);
		pe.Add(lItem);
  end;
  try
  for i := 0 to FDataList.Count - 1 do
  begin
    Application.ProcessMessages;
    liDataRec := PRMEFDataRec(FDataList[i]);
		lItem := pXLSExport(pe[i]);

    k := 0;
    while (k < FCols.Count) and not _CEP(TCol(FCols[k]).X, liDataRec^.X) do Inc(k);
    if k >= FCols.Count then
      lItem^.LeftCol := TCol(FCols[FCols.Add(TCol.CreateCol(liDataRec^.X))])
    else
      lItem^.LeftCol := TCol(FCols[k]);
    k := 0;
    while (k < FCols.Count) and not _CEP(TCol(FCols[k]).X, liDataRec^.X + liDataRec^.DX) do Inc(k);
    if k >= FCols.Count then
      lItem^.RightCol := TCol(FCols[FCols.Add(TCol.CreateCol(liDataRec^.X + liDataRec^.DX))])
    else
      lItem^.RightCol := TCol(FCols[k]);

    k := FrStart;
    while (k < FRows.Count) and not _CEP(TRow(FRows[k]).Y, liDataRec^.Y) do Inc(k);
    if k >= FRows.Count then
      lItem^.TopRow := TRow(FRows[FRows.Add(TRow.CreateRow(liDataRec^.Y, FPageNo))])
    else
      lItem^.TopRow := TRow(FRows[k]);
    k := FrStart;
    while (k < FRows.Count) and not _CEP(TRow(FRows[k]).Y, liDataRec^.Y + liDataRec^.DY) do Inc(k);
    if k >= FRows.Count then
      lItem^.BottomRow := TRow(FRows[FRows.Add(TRow.CreateRow(liDataRec^.Y + liDataRec^.DY, FPageNo))])
    else
      lItem^.BottomRow := TRow(FRows[k]);
  end;

  if VarIsEmpty(FSheet) or (FMultiSheet and (not FFirstPage)) then
    FSheet := FWorkBook.Sheets.Add(, FWorkBook.Sheets[FWorkBook.Sheets.Count]);

  FrStart := FrStart + FRows.Count;
  FCols.Sort(SortCols);
  FRows.Sort(SortRows);

  for i := 0 to FCols.Count - 1 do
    TCol(FCols[i]).Index := i;
  for i := 0 to FRows.Count - 1 do
    TRow(FRows[i]).Index := i;

  FKoefX := FExcel.InchesToPoints(1) * FSheet.Columns[1].ColumnWidth / XLS_EXPORT_LOGPIXELSX / FSheet.Columns[1].Width;
  FKoefY := FExcel.InchesToPoints(1) * FSheet.Rows[1].RowHeight / XLS_EXPORT_LOGPIXELSY / FSheet.Rows[1].Height;

  if FPageNo = 0 then
  begin
//    if CurReport.EMFPages[FPageNo].pgSize < 256 then
//      FSheet.PageSetup.PaperSize := CurReport.EMFPages[FPageNo].pgSize;
//    else
//      FSheet.PageSetup.PaperSize := xlPaperUser
//    FSheet.PageSetup.Orientation := XLSOrientation[CurReport.EMFPages[FPageNo].pgOr];
    FSheet.PageSetup.LeftMargin := 0;
    FSheet.PageSetup.TopMargin := 0;
    FSheet.PageSetup.RightMargin := 0;
    FSheet.PageSetup.BottomMargin := 0;
    FSheet.PageSetup.HeaderMargin := 0;
    FSheet.PageSetup.FooterMargin := 0;
  end;

  for i := 0 to FCols.Count - 1 do // 设置cell宽度
  begin
    if i = 0 then
      FSheet.Columns[i + 1].ColumnWidth := Min(MAX_EXCEL_COLUMN_WIDTH, FKoefX * TCol(FCols[i]).X)
    else
      FSheet.Columns[i + 1].ColumnWidth := Min(MAX_EXCEL_COLUMN_WIDTH, FKoefX * (TCol(FCols[i]).X - TCol(FCols[i - 1]).X));
  end;
  for i := 0 to FRows.Count - 1 do // 设置cell高度
  begin
    r := TRow(FRows[i]);
    if i = 0 then
      FSheet.Rows[i + 1].RowHeight := Min(MAX_EXCEL_ROW_HEIGHT, FKoefy * r.Y)
    else
    begin
      pr := TRow(FRows[i - 1]);
      if r.PageIndex = pr.PageIndex then
        FSheet.Rows[i + 1].RowHeight := Min(MAX_EXCEL_ROW_HEIGHT, FKoefY * (r.Y - pr.Y))
      else
      begin
        FSheet.Rows[i + 1].RowHeight := Min(MAX_EXCEL_ROW_HEIGHT, FKoefY * r.Y);
        FSheet.HPageBreaks.Add(FSheet.Rows[i + 1]);
      end;
    end;
  end;

  for i := 0 to FDataList.Count - 1 do
  begin
    Application.ProcessMessages;
    if CurReport.Terminated then Break;
    liDataRec := PRMEFDataRec(FDataList[i]);
		lItem := pXLSExport(pe[i]);

    lRange := FSheet.Range[FSheet.Cells[lItem^.TopRow.Index + 2, lItem^.LeftCol.Index + 2],
      FSheet.Cells[lItem^.BottomRow.Index + 1, lItem^.RightCol.Index + 1]];
    lFlag := True;
    for k := i + 1 to FDataList.Count -1 do
    begin
      Application.ProcessMessages;
      liDataRec1 := PRMEFDataRec(FDataList[k]);
      if (liDataRec1^.X >= liDataRec^.X) and (liDataRec1^.Y >= liDataRec^.Y) and
        (liDataRec1^.X + liDataRec1^.DX <= liDataRec^.X + liDataRec^.DX) and
        (liDataRec1^.Y + liDataRec1^.DY <= liDataRec^.Y + liDataRec^.DY) then
      begin
        lFlag := False;
        Break;
      end;    
    end;

    if lFlag then lRange.Merge;
    if liDataRec.Bitmap <> nil then
      _ExportImage
    else
      _ExportText;
  end;

  finally
	while pe.Count > 0 do
  begin
		Dispose(pXLSExport(pe[0]));
    pe.Delete(0);
  end;
  pe.Free;

  lRange := UnAssigned;
  if FMultiSheet then
  begin
    _ClearColsAndRows;
    FrStart := 0;
  end;
  FFirstPage := False;
  inherited OnEndPage;
  end;
end;

function TRMXLSExport.SaveBitmapAs(Bmp: TBitmap; ImgFormat: TRMEFImageFormat
{$IFDEF JPEG}; JPEGQuality: TJPEGQualityRange{$ENDIF}; const BaseName: string): string;
var
  DestStream: TStream;
  Img: TGraphic;

  procedure SaveJpgGif(const AFileName: string);
  begin
    DestStream := TFileStream.Create(AFileName, fmCreate);
    try
      Img.Assign(Bmp);
      Img.SaveToStream(DestStream);
    finally
      DestStream.Free;
      Img.Free;
    end;
  end;

begin
  Bmp.PixelFormat := FPixelFormat;
  Result := BaseName;
  case ImgFormat of
    ifBMP:
      begin
        Result := Result + '.bmp';
        Bmp.SaveToFile(Result);
      end;
    ifGIF:
      begin
{$IFDEF RXGIF}
        Result := Result + '.gif';
        Img := TGIFImage.Create;
{$ELSE}
{$IFDEF JPEG}
        Result := Result + '.jpg';
        Img := TJPEGImage.Create;
{$ELSE}
        Result := Result + '.bmp';
        Bmp.SaveToFile(Result);
{$ENDIF}
{$ENDIF}
        SaveJpgGif(Result);
      end;
    ifJPG:
      begin
{$IFDEF JPEG}
        Result := Result + '.jpg';
        Img := TJPEGImage.Create;
        TJPEGImage(Img).CompressionQuality := JPEGQuality;
        SaveJpgGif(Result);
{$ELSE}
        Result := Result + '.bmp';
        Bmp.SaveToFile(Result);
{$ENDIF}
      end;
  end;
end;


{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMXLSExportForm }

procedure TRMXLSExportForm.Localize;
begin
  Font.Name := RMLoadStr(SRMDefaultFontName);
  Font.Size := StrToInt(RMLoadStr(SRMDefaultFontSize));
  Font.Charset := StrToInt(RMLoadStr(SCharset));

  RMSetStrProp(chkExportImages, 'Caption', rmRes + 1821);
  RMSetStrProp(lblExportImageFormat, 'Caption', rmRes + 1816);
  RMSetStrProp(lblJPEGQuality, 'Caption', rmRes + 1814);
  RMSetStrProp(Label4, 'Caption', rmRes + 1788);

  RMSetStrProp(GroupBox1, 'Caption', rmRes + 044);
  RMSetStrProp(rdbPrintAll, 'Caption', rmRes + 045);
  RMSetStrProp(rbdPrintCurPage, 'Caption', rmRes + 046);
  RMSetStrProp(rbdPrintPages, 'Caption', rmRes + 047);
  RMSetStrProp(Label2, 'Caption', rmRes + 048);
  RMSetStrProp(GroupBox2, 'Caption', rmRes + 379);
  RMSetStrProp(Label1, 'Caption', rmRes + 378);
  RMSetStrProp(chkShowAfterGenerate, 'Caption', rmRes + 380);
  RMSetStrProp(CheckBox1, 'Caption', rmRes + 381);
  RMSetStrProp(chkMultiSheet, 'Caption', rmRes + 382);

  btnOK.Caption := RMLoadStr(SOk);
  btnCancel.Caption := RMLoadStr(SCancel);
end;

function TRMXLSExportForm.GetExportPages: string;
begin
  Result := '';
  if rbdPrintCurPage.Checked then
    Result := 'CURPAGE'
  else if rbdPrintPages.Checked then
    Result := edtPages.Text;
end;

procedure TRMXLSExportForm.FormCreate(Sender: TObject);
begin
  Localize;
  cbImageFormat.Items.Clear;
{$IFDEF RXGIF}
  cbImageFormat.Items.AddObject(ImageFormats[ifGIF], TObject(ifGIF));
{$ENDIF}
{$IFDEF JPEG}
  cbImageFormat.Items.AddObject(ImageFormats[ifJPG], TObject(ifJPG));
{$ENDIF}
  cbImageFormat.Items.AddObject(ImageFormats[ifBMP], TObject(ifBMP));
  cbImageFormat.ItemIndex := 0;
end;

procedure TRMXLSExportForm.btnFileNameClick(Sender: TObject);
begin
  SaveDialog.FileName := edtExportFileName.Text;
  if SaveDialog.Execute then
    edtExportFileName.Text := SaveDialog.FileName;
end;

procedure TRMXLSExportForm.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  if (ModalResult = mrOK) and (edtExportFileName.Text = '') then
    CanClose := False;
end;

procedure TRMXLSExportForm.rbdPrintPagesClick(Sender: TObject);
begin
  edtPages.SetFocus;
end;

procedure TRMXLSExportForm.edtPagesEnter(Sender: TObject);
begin
  rbdPrintPages.Checked := True;
end;

procedure TRMXLSExportForm.chkExportImagesClick(Sender: TObject);
begin
  RMSetControlsEnable(gbExportImages, chkExportImages.Checked);
  cbImageFormatChange(Sender);
end;

procedure TRMXLSExportForm.cbImageFormatChange(Sender: TObject);
begin
  if chkExportImages.Checked and (cbImageFormat.Text = ImageFormats[ifJPG]) then
  begin
    lblJPEGQuality.Enabled := True;
    edJPEGQuality.Enabled := True;
    edJPEGQuality.Color := clWindow;
  end
  else
  begin
    lblJPEGQuality.Enabled := False;
    edJPEGQuality.Enabled := False;
    edJPEGQuality.Color := clInactiveBorder;
  end;
end;

procedure TRMXLSExportForm.edJPEGQualityKeyPress(Sender: TObject;
  var Key: Char);
begin
  if not (Key in ['0'..'9', #8]) then
    Key := #0;
end;

initialization

finalization

end.