网友有个很特别的需求:将xlsx文件选定的单元格复制为图形,然后粘贴到其他单元格以保持复制的单元格不变形,需要用execl可以完成这个任务,我选择fpspreadsheet来解决这个问题。TsWorksheetGrid选择的Cell拷贝为图片。
已知问题:
超出可视范围复制会存在错位的问题。
复制粘贴后:
直接给出代码:
procedure TForm1.CopyCellToPic(ws:TsWorksheetGrid;bgColor:Boolean=true); var Image:TImage; RC1, RC2: TRect; range: TsCellRangeArray; w,h,y1,x1:integer; sel: TsCellRange; r, c: Cardinal; srccell: PCell; ACellFormat2:TsCellFormat; begin setlength(range,1); range:=ws.Workbook.ActiveWorksheet.GetSelection; if not bgcolor then //不保留背景颜色 begin for sel in ws.Workbook.ActiveWorksheet.GetSelection do begin for r := sel.Row1 to sel.Row2 do begin for c := sel.Col1 to sel.Col2 do begin srccell :=ws.Workbook.ActiveWorksheet.FindCell(r, c); if ws.Workbook.ActiveWorksheet.IsMerged(srccell) then srccell := ws.Workbook.ActiveWorksheet.FindMergeBase(srccell); if srccell <> nil then begin ACellFormat2:=ws.Workbook.ActiveWorksheet.ReadCellFormat(srccell); ACellFormat2.UsedFormattingFields:=[uffTextRotation, uffFont, uffBorder, uffNumberFormat, uffWordWrap, uffHorAlign, uffVertAlign, uffBiDi, uffProtection, uffDoNotPrint]; ws.Workbook.ActiveWorksheet.WriteCellFormat(srccell,ACellFormat2); end; end; end; end; end; ws.ClearSelections; ws.Refresh; range[0].Col1:=range[0].Col1+1; range[0].Col2:=range[0].Col2+1; range[0].Row1:=range[0].Row1+1; range[0].Row2:=range[0].Row2+1; Image:=TImage.Create(ws); w:=ws.CellRect(range[0].Col1,range[0].Row1,range[0].Col2,range[0].Row2).Width; h:=ws.CellRect(range[0].Col1,range[0].Row1,range[0].Col2,range[0].Row2).Height; x1:=ws.CellRect(0,0,range[0].Col1-1,range[0].Row1).Width; y1:=ws.CellRect(0,0,0,range[0].Row1-1).Height; Image.Width:=w; Image.Height:=h; RC1 := Rect(0, 0, w, h); RC2 := Rect(x1, y1, w+x1, h+y1); r:=ws.Workbook.ActiveWorksheet.ActiveCellRow; c:=ws.Workbook.ActiveWorksheet.ActiveCellCol; ws.ClearSelections; ws.Refresh; ws.Workbook.ActiveWorksheet.SelectCell(r+1,c+1); ws.ClearSelections; ws.Refresh; Image.Canvas.CopyRect(rc1,ws.Canvas,rc2); Stream:=TMemoryStream.Create; Image.Picture.SaveToStream(Stream); ws.Workbook.ActiveWorksheet.SelectCell(r,c); ws.ClearSelections; ws.Refresh; Image.Free; end; procedure TForm1.PasteCellToPic(ws:TsWorksheetGrid); var r,c:integer; begin if Stream<>nil then begin r:=ws.Workbook.ActiveWorksheet.ActiveCellRow; c:=ws.Workbook.ActiveWorksheet.ActiveCellCol; ws.Workbook.ActiveWorksheet. WriteImage(r, c, Stream); ws.Refresh; end; end;
标签:begin,ActiveWorksheet,TsWorksheetGrid,srccell,Cell,range,ws,Workbook,fpspreadshe From: https://www.cnblogs.com/qiufeng2014/p/18602106