【乾貨】Excel操作Word導出圖片

這篇文章講一個Word批量導出圖片的案例，下節課會講圖片導入Word的案例。

一、實際案例引入

這次遇到的案例需求：將檔案信息表中的個人圖片導出，以身份證號命名。具體表格結構如下的對應關係如下圖截圖中所示。

有n個格式一樣的基礎信息表，我們要做的就是把圖片導出，以身份證號來命名。

關於本篇所有配圖（均來自於網絡，侵刪）

二、思路及代碼

Q:

Word中圖形對象有哪些？

A:

在word中的圖形對象有InlineShape對象和Shape對象。其中InlineShape對象的是嵌入到文本層的圖片，是指將圖像作為文字處理，在排版上以文字的方式進行排版。而Shape對象是懸浮於文本之上位於圖形層，可以自由浮動，並且可以放置在頁面上的任何位置。

導出的時候也需要根據具體情況，來具體選擇循環的圖形對象。當然，你可以對這兩種對象分別循環導出。

關於Word VBA導出圖片有好幾種方法，這裡我比較推薦下面兩種：

■另存為html方法（導出後無損，推薦）

手動操作步驟：

核心代碼如下：

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

多個Word文檔批量導出圖片操作的話，對於一些特定要求（比如對圖片名有要求），就稍微麻煩些，這就需要打開html文件夾並修改文件名，然後再把圖片複製出來。

■複製到Excel後再導出圖片（本文採用的方法）

大致思路就是，Word文檔中的圖片複製到Excel中，然後Excel再利圖表導出圖片的功能導出。關於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對象，選擇文件夾對話框
        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循環獲取Word文檔
    Do While f <> ""
        Set WordDOC = wordapp.Documents.Open(p & f)     '逐個打開Word文件
        wordapp.Visible = True
        shenfen_num = l(WordDOC.Tables(1).cell(7, 2).Range) '獲取身份證號
        For i = 1 To WordDOC.Shapes.Count '對文檔中的圖片進行遍歷
            WordDOC.Shapes(i).Select '選中圖片
            wordapp.Selection.Copy '複製圖片。這裡不能合併為一句，否則報錯
            sht.PasteSpecial Format:="圖片(增強型圖元文件)", Link:=False, DisplayAsIcon:=False
            Set Excel_Shape = sht.Shapes(1) '因為當單個doc中存在圖片量過多，均複製到xls中造成數據量過大，
            Excel_Shape.ScaleHeight 1, True, msoScaleFromMiddle
            Excel_Shape.ScaleWidth 1, True, msoScaleFromMiddle
            '這裡採用了複製一個進入xls，再另存圖片後，立即刪除xls中的圖片數據，所以遍歷時，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 '刪除第二次複製產生的數據
            End With
            Excel_Shape.Delete '刪除第一次複製產生的數據
        Next i
        WordDOC.Close '關閉當前Word文檔
        f = Dir
    Loop
    wordapp.Quit '退出Word程序
End Sub
Function l(a) '清除Word表格中的不可見符號
    l = WorksheetFunction.Clean(a)
End Function


三、知識點

■選擇文件夾對話框

如果文件夾位置不確定，想獲取人為選擇的文件夾路徑，就要用到以下代碼塊。

    With Application.FileDialog(msoFileDialogFolderPicker) 'FileDialog對象，選擇文件夾對話框
        If .Show Then PathSht = .SelectedItems(1) Else Exit Sub
    End With
    PathSht = PathSht & IIf(Right(PathSht, 1) = "\", "", "\")


關於FileDialog對象更多功能，可以閱讀這篇文章：

■循環打開Word文檔

這裡是打開代碼文檔路徑下的文檔，如果需要打開其他路徑的文檔，結合上面的代碼。

Sub 循環打開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盤是否有例子文件夾，如果沒有，則新建一個名為「例子」的文件夾。

Sub 新建文件夾()
    myfile = "d:/例子"
    f = Dir(myfile, vbDirectory)'利用Dir函數，先獲取文件夾
    If f = "" Then MkDir myfile'找不到該文件夾，會返回空值。
End Su