通过搜索功能可以查询本站的所有文章
网站首页 本站动态 资源共享 美文妙乐 教学教案 双语新闻 论文相关 辅助教学 教学软件 广东高考

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页
扫一扫使用手机浏览或分享本页
相关文章
最新更新
阅读排行
快速导航
关于我们
联系我们
微信公众号 站长微信
版权所有 2008-2020 高中英语教学交流网