Delphi提取xlsx或docx中的图片

本人水平有限，如有错误，欢迎指正！

思路：在工作中经常会在word或Excel文件中插入图片，如果想把里面的文件提取出来，就需要打开文档，然后复制粘贴等一系列操作，为了减少工作步骤，开发了这个提取图片的小程序。

unit GetWordPicu1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, sBitBtn,
  sSkinManager, sLabel, sEdit, Vcl.Mask, sMaskEdit, sCustomComboEdit, sToolEdit,
  Vcl.ComCtrls, sListView, acShellCtrls, ieview, iemview, iexFolderMView,
  sDialogs,strutils,shellapi, sStatusBar;

type
  TForm1 = class(TForm)
    sSkinManager1: TsSkinManager;
    sLabel1: TsLabel;
    sEdit1: TsEdit;
    sBitBtn2: TsBitBtn;
    sLabel2: TsLabel;
    sDirectoryEdit1: TsDirectoryEdit;
    ImageEnFolderMView1: TImageEnFolderMView;
    sOpenDialog1: TsOpenDialog;
    sBitBtn1: TsBitBtn;
    sStatusBar1: TsStatusBar;
    procedure sBitBtn2Click(Sender: TObject);
    procedure sDirectoryEdit1Change(Sender: TObject);
    procedure sBitBtn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    function GetRndString(slen:Integer):string;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses SevenZip,IOUtils;

function TForm1.GetRndString(slen:Integer):string;
var
  SourceStr,str:string;
  i:integer;
begin
  SourceStr:='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789';
  randomize;
  for i:=1 to slen do
    str:=str+sourcestr[Random(62)+1];
  result:=str;
end;

function DelDirectory(const Source: string): boolean;
var
fo: TSHFILEOPSTRUCT;
begin
FillChar(fo, SizeOf(fo), 0);
with fo do
begin
Wnd := 0;
wFunc := FO_DELETE;
pFrom := PChar(Source + #0);
pTo := #0#0;
fFlags := FOF_NOCONFIRMATION + FOF_SILENT;
end;
Result := (SHFileOperation(fo) = 0);
end;

function CopyFiles(const Source,Dest: string): boolean;
var
fo: TSHFILEOPSTRUCT;
begin
FillChar(fo, SizeOf(fo), 0);
with fo do
begin
Wnd := 0;
wFunc := FO_COPY;
pFrom := @source[1];
pTo :=pchar(dest);
fFlags := FOF_NOCONFIRMATION+FOF_NOCONFIRMMKDIR ;
end;
Result := (SHFileOperation(fo) = 0);
end;

procedure TForm1.sBitBtn1Click(Sender: TObject);
var
  pa,wefilename,zipfilename,dirname,imagefilespath,destpath,msg:string;
begin
  if self.sEdit1.Text='' then
  begin
    showmessage('对不起，请先选择要提取图片的文档！');
    exit;
  end;
  if self.sDirectoryEdit1.Text='' then
  begin
    showmessage('对不起，请选择提取后的图片保存文件夹！');
    exit;
  end;
  destpath:=self.sDirectoryEdit1.Text+'\';
  wefilename:=self.sEdit1.Text;
  pa:=extractfilepath(Application.ExeName);
  if rightstr(pa,1)<>'\' then
    pa:=pa+'\';
  zipfilename:=pa+'TempFiles\'+replacestr(extractfilename(self.sEdit1.Text),ExtractFileExt(self.sEdit1.Text),'.zip');
  try
    //CopyFile(PWideChar(wefilename),PWideChar(zipfilename),false);//复制成zip文件
    CopyFiles(wefilename,zipfilename);
  finally
    //解压缩文件
    //在TempFiles下创建一个临时文件夹，用于解压缩
    dirname:=pa+'TempFiles\T_'+self.GetRndString(10)+'\';
    ForceDirectories(dirname);//创建多层文件夹
    with CreateInArchive(CLSID_CFormatZip) do
    begin
      //将1.zip中文件解压到C盘根目录
      OpenFile(zipfilename);
      ExtractTo(dirname);
      Close;
    end;
  end;
  if UpperCase(rightstr(wefilename,5))='.XLSX' then//如果是Excel文件
  begin
    imagefilespath:=dirname+'\xl\media\';
  end
  else
  begin
    imagefilespath:=dirname+'\word\media\';
  end;
  //把imagefilespath中的文件全部复制到
  try
    TDirectory.Copy(imagefilespath,destpath);
  finally
    self.ImageEnFolderMView1.RefreshFileList;
    //删除zip文件和dirname文件夹
    DelDirectory(dirname);
    DeleteFile(zipfilename);
    msg:='图片提取完毕，共提取图片'+inttostr(self.ImageEnFolderMView1.ImageCount)+'个！';
    ShowMessage(msg);
  end;
end;

procedure TForm1.sBitBtn2Click(Sender: TObject);
begin
  //将原文件复制成另一份的ZIP文件，然后对复制后的文件进行解压缩，提取图片文件并复制到目标文件夹中
  if self.sOpenDialog1.Execute then
  begin
    self.sEdit1.Text:=self.sOpenDialog1.FileName;

  end;
end;

procedure TForm1.sDirectoryEdit1Change(Sender: TObject);
begin
  self.ImageEnFolderMView1.Folder:=self.sDirectoryEdit1.Text;
end;

end.