word文档批量插入图片及其文件名

Sub PicWithCaption()
    Dim xFileDialog As FileDialog
    Dim xPath, xFile As Variant
    On Error Resume Next
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    If xFileDialog.Show = -1 Then
        xPath = xFileDialog.SelectedItems.Item(1)
        If xPath <> "" Then
            xFile = Dir(xPath & "\*.*")
            Do While xFile <> ""
                If UCase(Right(xFile, 3)) = "PNG" Or _
                    UCase(Right(xFile, 3)) = "TIF" Or _
                    UCase(Right(xFile, 3)) = "JPG" Or _
                    UCase(Right(xFile, 3)) = "GIF" Or _
                    UCase(Right(xFile, 3)) = "BMP" Then
                    With Selection
                        .InlineShapes.AddPicture xPath & "\" & xFile, False, True
                        .InsertAfter vbCrLf
                        .MoveDown wdLine
                        .Text = xPath & "\" & xFile & Chr(10)
                        .MoveDown wdLine
                        .MoveDown wdLine
                    End With
                End If
                xFile = Dir()
            Loop
        End If
    End If
End Sub

输入宏名，如：test

点击“新建”，然后在Sub test()与 End Sub间输入如下代码：

‘’’’’’’’’’’’’’’’’’’’

'插入一表格

ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:= _

       1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _

       wdAutoFitFixed

   With Selection.Tables(1)

       If .Style <> "网格型" Then

           .Style = "网格型"

       End If

       .ApplyStyleHeadingRows = True

       .ApplyStyleLastRow = False

       .ApplyStyleFirstColumn = True

       .ApplyStyleLastColumn = False

       .ApplyStyleRowBands = True

       .ApplyStyleColumnBands = False

   End With

   

   ' 显示 C:\目录下的名称。

MyPath = "F:\self\照片&视频\会展中心\"   ' 指定路径。最后必须加上\

MyName = Dir(MyPath, vbDirectory)   ' 找寻第一项。

Do While MyName <> ""   ' 开始循环。

   ' 跳过当前的目录及上层目录。

   If MyName <> "." And MyName <> ".." Then

       ' 使用位比较来确定 MyName代表一目录。

       If InStr(MyName, "jpg") Then

          ' Debug.Print MyName    ' 如果它是一个目录，将其名称显示出来。

           Selection.InsertRows 1

           Selection.Collapse Direction:=wdCollapseStart

           

           Selection.InlineShapes.AddPicture FileName:=MyPath + MyName, LinkToFile:= _

       False, SaveWithDocument:=True

           Selection.TypeText Text:=MyName

       End If

   End If

   MyName = Dir    ' 查找下一个目录。

Loop

‘’’’’’’’’’’’’’’’’’’’’’’’’’
————————————————