使用VBA批量导入图片到表格中

在做一份材料的时候需要将一份清单上的人的身份证照片填入word文档中，考虑到人数较多，就做了下面这个宏来处理。

图片存放在pics目录下，图片后缀为.jpg

导入的图片名称存放在list.txt中，不需要带.jpg

Function CreateTable() As Table
    Dim docActive As Document
    Dim celTable As Cell
    Set docActive = ActiveDocument
    Set CreateTable = docActive.Tables.Add( _
        Range:=docActive.Range(Start:=0, End:=0), NumRows:=1, _
        NumColumns:=3)
    CreateTable.Borders.InsideLineStyle = wdLineStyleSingle
    CreateTable.Borders.OutsideLineStyle = wdLineStyleSingle
    
    
    CreateTable.Cell(1, 1).Range.Text = "序号"
    CreateTable.Cell(1, 2).Range.Text = "姓名"
    CreateTable.Cell(1, 3).Range.Text = "证件"
    
    CreateTable.Columns(1).SetWidth ColumnWidth:=40, RulerStyle:=wdAdjustSameWidth
    CreateTable.Columns(2).SetWidth ColumnWidth:=40, RulerStyle:=wdAdjustSameWidth
    CreateTable.Columns(3).SetWidth ColumnWidth:=360, RulerStyle:=wdAdjustSameWidth
    
End Function


Function IsFileExists(ByVal strFileName As String) As Boolean
    Dim objFileSystem As Object
  
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    If objFileSystem.fileExists(strFileName) = True Then
        IsFileExists = True
    Else
        IsFileExists = False
    End If
End Function

Sub InsertOne(tbl As Table, name As String)
    Dim lastRow
    Dim line
    Dim pic
    Dim picPath
    Dim w
    
    tbl.Rows.Add
    line = tbl.Rows.Count
    picPath = "pics\\" & name & ".jpg"
    
    tbl.Cell(line, 1).Range.Text = line - 1
    tbl.Cell(line, 2).Range.Text = name
    
    If IsFileExists(picPath) = True Then
        Set pic = tbl.Cell(line, 3).Range.InlineShapes.AddPicture(FileName:=picPath, SaveWithDocument:=True)
        w = pic.Width
        pic.Width = 340
        pic.Height = 340 / w * pic.Height
    End If
End Sub



Sub ImportPicture()
    Dim txt As String
    Dim tbl As Table
    
    ChDir ActiveDocument.Path
    Set tbl = CreateTable()
        
    Open "list.txt" For Input As #1
    Do While Not EOF(1)
        Line Input #1, txt
        InsertOne tbl, txt
    Loop
    Close #1
End Sub