Sub 批量插入图片()
    Dim myfile As FileDialog
    Set myfile = Application.FileDialog(msoFileDialogFilePicker)
    Application.ScreenUpdating = False
    With myfile
        .InitialFileName = "D:\PicDir"
        If .Show = -1 Then
            For Each Fn In .SelectedItems
                Selection.Text = Basename(Fn)
                Selection.EndKey
                If Selection.Start = ActiveDocument.Content.End - 1 Then
                    Selection.TypeParagraph
                Else
                    Selection.MoveDown
                End If
                Set mypic = Selection.InlineShapes.AddPicture(FileName:=Fn, SaveWithDocument:=True)
                If Selection.Start = ActiveDocument.Content.End - 1 Then 
                    Selection.TypeParagraph
                    Selection.TypeParagraph
                Else
                    Selection.MoveDown
                End If
            Next Fn
        Else
        End If
    End With
    Set myfile = Nothing
    Application.ScreenUpdating = True
End Sub
Function Basename(FullPath)
    Dim x, y
    Dim tmpstring
    tmpstring = FullPath
    x = Len(FullPath)
    For y = x To 1 Step -1
        If Mid(FullPath, y, 1) = "\" Or _
            Mid(FullPath, y, 1) = ":" Or _
            Mid(FullPath, y, 1) = "/" Then
            tmpstring = Mid(FullPath, y + 1)
            Exit For
        End If
    Next
    Basename = Left(tmpstring, Len(tmpstring) - 4)
End Function
复制代码