這篇文章講一個(gè)Word批量導出圖片的案例，下節課會(huì )講圖片導入Word的案例。
這次遇到的案例需求：將檔案信息表中的個(gè)人圖片導出，以身份證號命名。具體表格結構如下的對應關(guān)系如下圖截圖中所示。
有n個(gè)格式一樣的基礎信息表，我們要做的就是把圖片導出，以身份證號來(lái)命名。
關(guān)于本篇所有配圖（均來(lái)自于網(wǎng)絡(luò )，侵刪）
關(guān)于Word VBA導出圖片有好幾種方法，這里我比較推薦下面兩種：
■另存為html方法（導出后無(wú)損，推薦）
手動(dòng)操作步驟：
核心代碼如下：
Sub doc另存為HTML()
Dim WordDOC As Object
Dim Path, Name As String
Set WordDOC = Documents.Open("C:\Brildo\Test.docx")
Path = WordDOC.Path
Name = WordDOC.Name
ActiveDocument.SaveAs2 FileName:=Path & "\" & Split(Name, ".")(0), FileFormat:=wdFormatHTML
ActiveDocument.Close (0)
End Sub多個(gè)Word文檔批量導出圖片操作的話(huà)，對于一些特定要求（比如對圖片名有要求），就稍微麻煩些，這就需要打開(kāi)html文件夾并修改文件名，然后再把圖片復制出來(lái)。
■復制到Excel后再導出圖片（本文采用的方法）
大致思路就是，Word文檔中的圖片復制到Excel中，然后Excel再利圖表導出圖片的功能導出。關(guān)于Excel如何批量導出圖片，看我之前的文章代碼合集，各取所需【操作圖片】
完整代碼：
Sub 導出Word圖片()
Dim PathSht As String, wb As Workbook
Application.ScreenUpdating = False
For Each shp In ActiveSheet.Shapes '清除本表中的圖片
shp.Delete
Next
With Application.FileDialog(msoFileDialogFolderPicker) 'FileDialog對象，選擇文件夾對話(huà)框
If .Show Then PathSht = .SelectedItems(1) Else Exit Sub
End With
PathSht = PathSht & IIf(Right(PathSht, 1) = "\", "", "\")
myfile = PathSht & "保存圖片"
fol = Dir(myfile, vbDirectory)
If fol = "" Then MkDir myfile '新建存儲圖片的路徑
myname = Dir(PathSht & "*.doc*")
Call wd_pic(PathSht)
MsgBox "完成！"
Application.ScreenUpdating = True
End Sub
Sub wd_pic(p As String)
Set wordapp = CreateObject("word.application")
Set sht = ThisWorkbook.ActiveSheet
f = Dir(p & "*.doc*") '結合Do While循環(huán)獲取Word文檔
Do While f <> ""
Set WordDOC = wordapp.Documents.Open(p & f) '逐個(gè)打開(kāi)Word文件
wordapp.Visible = True
shenfen_num = l(WordDOC.Tables(1).cell(7, 2).Range) '獲取身份證號
For i = 1 To WordDOC.Shapes.Count '對文檔中的圖片進(jìn)行遍歷
WordDOC.Shapes(i).Select '選中圖片
wordapp.Selection.Copy '復制圖片。這里不能合并為一句，否則報錯
sht.PasteSpecial Format:="圖片(增強型圖元文件)", Link:=False, DisplayAsIcon:=False
Set Excel_Shape = sht.Shapes(1) '因為當單個(gè)doc中存在圖片量過(guò)多，均復制到xls中造成數據量過(guò)大，
Excel_Shape.ScaleHeight 1, True, msoScaleFromMiddle
Excel_Shape.ScaleWidth 1, True, msoScaleFromMiddle
'這里采用了復制一個(gè)進(jìn)入xls，再另存圖片后，立即刪除xls中的圖片數據，所以遍歷時(shí)，index永遠是1
Excel_Shape.Copy
With sht.ChartObjects.Add(0, 0, Excel_Shape.Width, Excel_Shape.Height).Chart
.Parent.Select '64位必須加這句，否則導出后是空白圖片
.Paste
.Export p & "保存圖片\" & shenfen_num & ".bmp"
.Parent.Delete '刪除第二次復制產(chǎn)生的數據
End With
Excel_Shape.Delete '刪除第一次復制產(chǎn)生的數據
Next i
WordDOC.Close '關(guān)閉當前Word文檔
f = Dir
Loop
wordapp.Quit '退出Word程序
End Sub
Function l(a) '清除Word表格中的不可見(jiàn)符號
l = WorksheetFunction.Clean(a)
End Function
■選擇文件夾對話(huà)框
如果文件夾位置不確定，想獲取人為選擇的文件夾路徑，就要用到以下代碼塊。
With Application.FileDialog(msoFileDialogFolderPicker) 'FileDialog對象，選擇文件夾對話(huà)框
If .Show Then PathSht = .SelectedItems(1) Else Exit Sub
End With
PathSht = PathSht & IIf(Right(PathSht, 1) = "\", "", "\")
關(guān)于FileDialog對象更多功能，可以閱讀這篇文章：獲取文件全路徑（二）FileDialog對象
■循環(huán)打開(kāi)Word文檔
這里是打開(kāi)代碼文檔路徑下的文檔，如果需要打開(kāi)其他路徑的文檔，結合上面的代碼。
Sub 循環(huán)打開(kāi)Word文檔框架()
Set doc = CreateObject("word.application")
f = Dir(ThisWorkbook.Path & "\*.doc")
Do While f <> ""
Set wd = doc.Documents.Open(ThisWorkbook.Path & "\" & f)
doc.Visible = True
'你要操作的核心代碼
f = Dir
wd.Close False
Loop
doc.Quit
MsgBox "完成！"
End Sub
■新建文件夾
該段代碼作用：判斷D盤(pán)是否有例子文件夾，如果沒(méi)有，則新建一個(gè)名為“例子”的文件夾。
Sub 新建文件夾()
myfile = "d:/例子"
f = Dir(myfile, vbDirectory)'利用Dir函數，先獲取文件夾
If f = "" Then MkDir myfile'找不到該文件夾，會(huì )返回空值。
End Su聯(lián)系客服
