rm_e_xls1.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 647 行 · 第 1/2 页

      begin
        FExcel.Sheets[0].RowHeights[RMEXCELCELL(frows.Items[i]).rowindex] := TRMEFDataRec(fdatalist.Items[RMEXCELCELL(frows.Items[i]).fdatalistindex]).Width * XLSscaleheight;
      end
      else
      begin
        FExcel.Sheets[0].RowHeights[RMEXCELCELL(frows.Items[i]).rowindex + getrowcount] := TRMEFDataRec(fdatalist.Items[RMEXCELCELL(frows.Items[i]).fdatalistindex]).Height * XLSscaleheight;
      end;
    end;
      //记录行数
    i2 := RMEXCELCELL(frows.Items[frows.count - 1]).rowindex;
    Fpagemaxrowindex[FPageNo] := RMEXCELCELL(frows.Items[frows.count - 1]).rowindex;
  end;

  function getrowindex(frows: tlist; index: integer): integer;
  var
    i: integer;
  begin
    for i := 0 to frows.Count - 1 do
    begin
      if index = RMEXCELCELL(frows.Items[i]).fdatalistindex then
      begin
        result := RMEXCELCELL(frows.Items[i]).rowindex;
        exit;
      end;
    end;
  end;

  function getrowvalue(frows: tlist; index: integer): integer;
  var
    i: integer;
  begin
    for i := 0 to frows.Count - 1 do
    begin
      if index = RMEXCELCELL(frows.Items[i]).fdatalistindex then
      begin
        result := RMEXCELCELL(frows.Items[i]).row;
        exit;
      end;
    end;
  end;

  procedure setpicwidth(Pic: TPicture; NewWidth, NewHeight: Integer); //根据产品编号获取图片
  var
    PicW, PicH: Integer;
    rz, Rz1, rz2: Double;
    Bmp1, Bmp2: TBitMap;
  begin
    if NewWidth * NewHeight > 0 then
    begin
      Picw := pic.Width;
      PicH := pic.Height;
      if PicW * Picw = 0 then
      begin
   //      ShowMessage('Width Or Height Is 0');
        exit;
      end;
      Rz1 := NewWidth / Picw;
      Rz2 := NewHeight / Pich;
      Rz := Min(Rz1, Rz2);
      if Rz < 1 then
      begin
        Bmp1 := TBitMap.Create;
        Bmp1.Width := Picw;
        Bmp1.Height := PicH;
        Bmp1.Assign(Pic.Graphic);
        Picw := Trunc(Picw * Rz);
        PicH := Trunc(Pich * Rz);
        Bmp2 := TBitMap.Create;
        Bmp2.Width := Picw;
        Bmp2.Height := Pich;
        Bmp2.Canvas.StretchDraw(Bmp2.Canvas.ClipRect, Bmp1); // 伸展缩小图片
        Pic.Assign(Bmp2);
        Bmp1.Free;
        Bmp2.Free;
      end;
    end;
  end;

  procedure setpic(picpath: string; fpicture: tpicture);
  var
    jpeg: tjpegimage;
    viewform: tform;
    ls_datasetname, ls_fieldname, ls_datafield: string;
    i: integer;
  begin
    if fileexists(picpath) then
    begin
      Jpeg := TJPEGImage.Create();
      jpeg.LoadFromFile(picpath);
      fpicture.Assign(jpeg);
    end;
  end;

  procedure _ExportPicture;
  begin
{    if fileexists(lDataRec.picturename) then
    begin
      fpicture := tpicture.Create;
      setpic(lDataRec.picturename, fpicture); //szcadd
      setpicwidth(fpicture, lDataRec.dx, lDataRec.dy);
//        FExcel.Sheets[0].MergedCells := FExcel.Sheets[0].Cells[1,1,2,2];
      with FExcel.Pictures.Add do
      begin
        Filename := lDataRec.picturename;
        Width := trunc(fpicture.Width / 1.15);
        Height := trunc(16 / 1.15); //fpicture.Height - (lDataRec.dy-20)  ;
        FExcel.Sheets[0].RowHeights[RMEXCELCELL(frows.Items[i]).rowindex] := TRMEFDataRec(fdatalist.Items[RMEXCELCELL(frows.Items[i]).fdatalistindex]).dy * XLSscaleheight;
//          showmessage(inttostr(height));
      end;
      fpicture.free;
      with FExcel.Sheets[0].SheetPictures.add do
      begin
        col := li_col;
        row := li_row;
        PictureName := lDataRec.picturename;
      end;
    end;
}  end;

  procedure _ExportText;
  var
    i, lCount: Integer;
    lText: string;
  begin
    lCount := lDataRec.Obj.Memo.Count;
    lText := '';
    for i := 0 to lCount - 1 do
    begin
      if i <> 0 then
        lText := lText + #13#10;
      lText := lText + lDataRec.Obj.Memo[i];
    end;
    lText := RMReplaceString(lText, #1, '');

    FExcel.Sheets[0].WriteWideString(li_col, li_row, 0, lText);
  end;

begin
  for i := 0 to fdatalist.Count - 1 do
  begin
    new(ECELL1);
    new(ECELL2);
    new(ECELL3);
    ECELL1^.row := 0;
    ECELL1^.col := 0;
    ECELL1^.fdatalistindex := 0;
    ECELL2^.row := 0;
    ECELL2^.col := 0;
    ECELL2^.fdatalistindex := 0;
    ECELL3^.row := 0;
    ECELL3^.col := 0;
    ECELL3^.fdatalistindex := 0;
    Fsheet.Add(ECELL1);
    fcols.Add(ECELL2);
    frows.Add(ECELL3);
  end;

  x := 0; y := 0; index := 0;
  for i := 0 to fdatalist.Count - 1 do
  begin
    lDataRec := TRMEFDataRec(Fdatalist.items[i]);
    RMEXCELCELL(fcols.Items[i]).col := lDataRec.Left;
    RMEXCELCELL(fcols.Items[i]).fdatalistindex := i;
    RMEXCELCELL(frows.Items[i]).row := lDataRec.Top;
    RMEXCELCELL(frows.Items[i]).fdatalistindex := i;
  end;

  sortcol(fcols, FExcel); //排序
  sortrow(frows, FExcel);
  //设置行列
  for i := 0 to fcols.Count - 1 do
  begin
    index := RMEXCELCELL(fcols.Items[i]).fdatalistindex;
    RMEXCELCELL(Fsheet.Items[i]).fdatalistindex := index;
    RMEXCELCELL(Fsheet.Items[i]).colindex := RMEXCELCELL(fcols.Items[i]).colindex;
    RMEXCELCELL(Fsheet.Items[i]).rowindex := getrowindex(frows, index) + getrowcount;
    RMEXCELCELL(Fsheet.Items[i]).col := RMEXCELCELL(fcols.Items[i]).col;
    RMEXCELCELL(Fsheet.Items[i]).row := getrowvalue(frows, index);
  end;

  FExcel.FuncArgSeparator := ';';
  FExcel.WriteUnicodeStrings := true;
  self.Stream.free;
  self.Stream := nil;
  if fileexists(self.FExportFileName) then
    DeleteFile(pchar(self.FExportFileName));
  if fileexists(self.FExportFileName) then
    DeleteFile(pchar(self.FExportFileName));
  with FExcel.Formats.Add do
  begin
    FontIndex := FExcel.Fonts.AddIndex;
    FExcel.Fonts[FontIndex].Name := 'Courier new';
    FExcel.Fonts[FontIndex].Size := 14;
    FExcel.Fonts[FontIndex].Color := xcred;
  end;
  y := 0;
  for i := 0 to fsheet.Count - 1 do
  begin
    li_col := RMEXCELCELL(fsheet.Items[i]).colindex;
    li_row := RMEXCELCELL(fsheet.Items[i]).rowindex;
    index := RMEXCELCELL(fsheet.Items[i]).fdatalistindex;
    lDataRec := TRMEFDataRec(Fdatalist.items[index]);
    case lDataRec.ObjType of
      rmotMemo: _ExportText;
      rmotPicture: _ExportPicture;
    end;
  end;
end;

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

procedure TRMXLSExport1Form.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(chkExportFrames, 'Caption', rmRes + 1803); //导出框线
  RMSetStrProp(chkMultiSheet, 'Caption', rmRes + 382);

  RMSetStrProp(Self, 'Caption', rmRes + 1779);
  btnOK.Caption := RMLoadStr(SOk);
  btnCancel.Caption := RMLoadStr(SCancel);
end;

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

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

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

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

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

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

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

procedure TRMXLSExport1Form.cmbImageFormatChange(Sender: TObject);
begin
  if chkExportImages.Checked and (cmbImageFormat.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 TRMXLSExport1Form.edJPEGQualityKeyPress(Sender: TObject;
  var Key: Char);
begin
  if not (Key in ['0'..'9', #8]) then
    Key := #0;
end;

initialization

finalization

end.