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页

相关文章
·BIos密码权限设置05-25
·U盘使用误区面面观08-30
·WORD批量插入图片和文件名11-12
·Excel 利用行号引用数据09-02
·合并当前目录下所有工作簿的全部工作01-10
·批量设置PowerPoint字体及行间距——VBA宏10-02
·任务栏上的显示桌面图标不见了,怎么办?09-17
·我的电脑图标不见了怎么办?10-29
·Excel随机生成区间数值06-23
·破解不能复制修改的word文档 06-13
最新文章
阅读排行