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
'-----------重复插入图片
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页
- 相关文章
- ·115网盘多人使用防踢软件10-23·隐藏Excel错误结果显示的三种方法10-12·出于安全原因,Firefox 取消了该请求03-22·制作Word2003选择性粘贴快捷键07-09·四行选项变一行的快捷方法11-14·如何更改Excel默认另存为的路径?04-16·Word高级替换技巧03-05·用vlookup从右向左查询(逆向查询)吗?01-20·JS 自动答题脚本07-01·win7 隐藏文件夹设置方法08-14
- 最新文章
- ·Win10系统开机启动文件夹在哪里?04-16·十秒免工具激活windows 1002-25·批量替换word文档中的第一行作为文件的文件名06-21·连接打印机时需要输入用户名密码怎么办?05-15·免魔法使用 New Bing 新方案03-18·Win10电脑账号密码设置、修改、取消12-06·[亲测有效]excel批量修改文件名10-29
- 阅读排行
- ·如何让试题的ABCD选项对齐04-13·word排版技巧整理08-02·word 如何自动生成目录08-02·不同电脑文件字体改变了的解决方法12-15·Excel 进行学生成绩统计分析03-13·我的电脑图标不见了,怎么找回来!09-14·Win10电脑的一些安装提示12-03·Word高级替换技巧03-05·Excel如何批量插入分页符02-12·制作Word2003选择性粘贴快捷键07-09
2008-2024 | www.zshunj.cn |www.yykz.net
点击这里识别二维码关注公众号
点击这里识别二维码关注公众号