WORD批量插入图片和文件名


来源:网络整理
发布时间:2019-11-12 10:42:00
查看次数:

内容提要:因为需要,找了两个VBA代码。

Option Explicit
'-----------重复插入图片
Public Sub RepeatInsertPic(ByVal pfile As String)
    Dim rg As Range
    Dim doc As Document
    Set doc = ActiveDocument
    Set rg = doc.Range(doc.Range.End - 1, doc.Range.End)
    rg.InsertAfter pfile & vbCrLf
    Set rg = doc.Range(doc.Range.End - 1, doc.Range.End)
    rg.InlineShapes.AddPicture pfile
    Set rg = doc.Range(doc.Range.End - 1, doc.Range.End)
    rg.InsertParagraphAfter
    Set rg = Nothing
    Set doc = Nothing
End Sub
'----------遍历文件夹,获取文件列表
Public Function BsearchFile1(ByVal spath As String, ByVal filesuf As String, ByRef filelist() As String) As Integer
    Dim MyName, Dic, Did, i, T, f, TT, MyFileName, lj, Ke
    Dim j As Integer
    j = 0
    lj = spath & "\"
    T = Timer
    Set Dic = CreateObject("Scripting.Dictionary")    '---------创建一个字典对象
    Set Did = CreateObject("Scripting.Dictionary")
    Dic.Add (lj), ""
    i = 0
    Do While i < Dic.Count
        Ke = Dic.Keys    '-----------开始遍历字典
        MyName = Dir(Ke(i), vbDirectory)    '-----------查找目录
        Do While MyName <> ""
            If MyName <> "." And MyName <> ".." Then
                If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then
                    Dic.Add (Ke(i) & MyName & "\"), ""
                End If
            End If
            MyName = Dir
        Loop
        i = i + 1
    Loop
    For Each Ke In Dic.Keys
        MyFileName = Dir(Ke & filesuf)
        Do While MyFileName <> ""
            Did.Add (Ke & MyFileName), ""
            filelist(j) = Ke & MyFileName
            MyFileName = Dir
            j = j + 1
        Loop
    Next
    BsearchFile1 = j
End Function

'--------------插入图片
Sub InsertPicFromFolder()
    Dim spath As String
    spath = "F:\11"    '-----------这个图片保存路径可以自己去" 改?
    Dim hz As String
    hz = "*.png"    '-----------这里是文件通配符
    Dim flist(2000) As String    '----------定义数组,最多 2000个图片
    Erase flist
    Dim ic As Integer
    ic = BsearchFile1(spath, hz, flist)
    If ic > 0 Then
        Dim f
        For Each f In flist
            If VBA.Trim(f) <> "" Then Call RepeatInsertPic(f)
        Next
        MsgBox "插入" & ic & "张图片成功,请检查!", vbInformation + vbOKOnly, "提示"
    Else
        MsgBox "路径下无图片文件,请检查!", vbCritical + vbOKOnly, "提示"
    End If
End Sub

第1页 第2页

相关文章
·常见屏幕截图方法08-11
·qlv格式视频转mp4方法08-10
·去掉word中的隔行回车03-23
·磁带转录成MP3操作方法 09-23
·我的电脑图标不见了,怎么找回来! 09-14
·解决gmail不稳定的方法03-17
·隐藏Excel错误结果显示的三种方法10-12
·word删除两个字符之间的内容11-29
·完美解决WPS 2019 中的 VBA 不能用的问题12-29
·如何压缩word?10-19
最新文章
阅读排行