点击这里查看首页

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页

相关文章
·小册子打印代码07-07
·excel里如何把一列多行等分成多列?07-13
·磁带转录成MP3操作方法 09-23
·解决Win8 IE浏览器某些网站显示不全01-30
·批量设置PowerPoint字体及行间距——VBA宏10-02
·发送手机文件到电脑的方法11-01
·让Windows XP自动登录的三种方法09-14
·快速创建以当前日期命名的文件夹05-15
·将纸质版文字材料转为电子版12-23
·win8 iis8.0 安装获取方法01-22
最新文章
·十秒免工具激活windows 1002-25
·批量替换word文档中的第一行作为文件的文件名06-21
·自动对一个文件夹下的N个word文件批量执行一个宏06-21
·Win10电脑开机启动慢?教你只需三步,电脑开机速度快06-11
·连接打印机时需要输入用户名密码怎么办?05-15
·免魔法使用 New Bing 新方案03-18
·Win10电脑账号密码设置、修改、取消12-06
·视频加速脚本TimerHooker (计时器掌控者)06-17
·[亲测有效]excel批量修改文件名10-29
·Excel随机生成区间数值06-23
阅读排行