注册 登录  
 加关注
查看详情
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

银河军团大本营

光荣的军团,永远的丰碑 <坚持原创>

 
 
 

日志

 
 

通过OLE从Excel中抽取图片  

2013-05-22 19:57:21|  分类: 编程小技巧 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

  要通过OLE从Excel中抽取图片,貌似只能利用剪贴板来间接实现。在实现抽取Excel中图片的过程中,发现一些陷阱:

  1.Copy方法会直接将图片导出,且对Shape来说,Copy可能会导致导出“组合”的图片出现重叠的错误;

  2.CopyPicture方法貌似只能使用(xlScreen, xlBitmap)这种组合的参数来调用?测试时发现其他组合都不支持;

  3.图片如果位于“组合”中,则使用Pictures是读不出来的,必须使用Shapes;而Shapes中是包含Picture的;

  闲话少说,详见下面的例子代码。

PAS:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, ActnList, Clipbrd, ActiveX, ComObj{$IFNDEF VER130}, Variants{$ENDIF};

type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
ActionList1: TActionList;
actOpenFile: TAction;
procedure FormShow(Sender: TObject);
procedure actOpenFileExecute(Sender: TObject);
private
{ Private declarations }
FImgTop: Integer;
procedure ClearImages;
procedure ExtractExcelImages(const AExcelFile: string);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

type
XlPictureAppearance = TOleEnum;
const
xlPrinter = $00000002;
xlScreen = $00000001;

type
XlCopyPictureFormat = TOleEnum;
const
xlBitmap = $00000002;
xlPicture = $FFFFEFCD;


procedure TForm1.FormShow(Sender: TObject);
begin
AutoScroll := True;
actOpenFile.Execute;
end;

procedure TForm1.actOpenFileExecute(Sender: TObject);
begin
if OpenDialog1.Execute then begin
ClearImages;
ExtractExcelImages(OpenDialog1.FileName);
end;
end;

procedure TForm1.ClearImages;
var
i: Integer;
list: TList;
begin
FImgTop := 0;

list := TList.Create;
try
for i := 0 to ComponentCount -1 do begin
if Components[i] is TImage then begin
list.Add(Components[i]);
end;
end;
for i := 0 to list.Count -1 do begin
TImage(list[i]).Free;
end;
finally
list.Free;
end;
end;

procedure TForm1.ExtractExcelImages(const AExcelFile: string);

procedure CopyPictureFromClipboard;
begin
Clipboard.Open;
try
with TImage.Create(Self) do begin
AutoSize := True;
Picture.Assign(Clipboard);
Parent := Self;
Left := 0;
Top := FImgTop;
Show;
Inc(FImgTop, Height);
end;
finally
Clipboard.Close;
end;
end;

procedure ExtractSheetImages(const ASheet: Variant);
var
i: Integer;
begin
// extract pictures
for i := 1 to ASheet.Pictures.Count do begin
//Copy会将图片原样导出
//CopyPicture(..,..)则会以当前显示大小导出,且会平滑处理
//CopyPicture经测试只能用xlScreen, xlBitmap作参数,其他的不支持?!
ASheet.Pictures[i].CopyPicture(xlScreen, xlBitmap); //Copy;
if Clipboard.HasFormat(CF_PICTURE) then begin
CopyPictureFromClipboard;
end;
end;

// extract shapes
// 抽取组合中的图片,需要从Shapes中取得
for i := 1 to ASheet.Shapes.Count do begin
//对Shape来说,Copy可能会出现图片重叠的错误
ASheet.Shapes.Item(i).CopyPicture(xlScreen, xlBitmap); //!!
if Clipboard.HasFormat(CF_PICTURE) then begin
CopyPictureFromClipboard;
end;
end;
end;

var
excel: Variant;
sheet: Variant;
i: Integer;
begin
excel := CreateOleObject('Excel.Application');
try
excel.DisplayAlerts := False;
excel.WorkBooks.Open(AExcelFile);
for i := 1 to excel.WorkSheets.Count do begin
sheet := excel.WorkSheets[i];
if not sheet.Visible then Continue;
sheet.Activate;
ExtractSheetImages(sheet);
end;
finally
excel.Quit;
excel := Unassigned;
end;
end;

end.

DFM:

object Form1: TForm1
Left = 192
Top = 104
Width = 870
Height = 640
Caption = 'Excel OLE Testing'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object OpenDialog1: TOpenDialog
Filter = 'Excel File(*.xls;*.xlsx)|*.xls;*.xlsx'
Left = 72
Top = 72
end
object ActionList1: TActionList
Left = 120
Top = 72
object actOpenFile: TAction
Caption = '&Open'
ShortCut = 16463
OnExecute = actOpenFileExecute
end
end
end

  以上代码在Delphi 5/Delphi 2010/Delphi XE2及Excel 2003中测试通过。

  评论这张
 
阅读(690)| 评论(0)
推荐 转载

历史上的今天

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2018