ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 33628|回复: 65

[分享] 批量插入图片

  [复制链接]

TA的精华主题

TA的得分主题

发表于 2011-12-5 21:45 | 显示全部楼层 |阅读模式
本帖最后由 维所慾維 于 2011-12-5 22:10 编辑

经过几天的实验,今天终于弄好了.为什么弄这个程序,都是因为年底,工作总结的时候,需要插入一年工作中收集的图片,然后打印出来做存底资料.还要按照一定的顺序插入.
好让我来分享下我的小小成果吧:
我家宝贝给它取了个惊讶的名字:小三之黑板报1号

其实她什么都不懂,呵呵,但是是我灵感的源泉,我也不知道为什么,反正就是弄出来了.
先上源代码(全部复制出来,逐一分析),之后有附件,直接下载使用就好了,不用到文章复制了.
ps:其实写代码很简单,就看你有没有耐心去想,遇到问题,能不能分段处理解决,然后把所有功能整合起来,然后在把调试好的程序,用窗体表现出来,就可以给大众用了.
我的程序做了个窗体:
1.png
我想让下面文件夹的文件所有图片,包括名字自动插入word里面
2.jpg
名称中1,2,3使用来排序的,输入word里面后的文字要去除排序用的数字
然后在窗体里面写入文件夹所在地址,输入进去,其实可以不要输入,直接打开文件夹后,复制地址栏的路径就可以了,然后运行就得到下图效果:

3.jpg
ps:都是按照文件名排序过去的
4.jpg

下面是运行按钮里面的程序(每段功能都有意识的分开了):
Private Sub CommandButton1_Click()
'*************************************************
'设定页边距
With ActiveDocument.Styles(wdStyleNormal).Font
        If .NameFarEast = .NameAscii Then
            .NameAscii = ""
        End If
        .NameFarEast = ""
    End With
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = CentimetersToPoints(1.54)     '上边距
        .BottomMargin = CentimetersToPoints(1.54)   '下边距
        .LeftMargin = CentimetersToPoints(2.5)       '左边距
        .RightMargin = CentimetersToPoints(2.5)      '右边距
        .Gutter = CentimetersToPoints(0)
        .HeaderDistance = CentimetersToPoints(1.5)  '页眉
        .FooterDistance = CentimetersToPoints(1.75) '页脚
        .PageWidth = CentimetersToPoints(21)    'A4纸的设置
        .PageHeight = CentimetersToPoints(29.7) 'A4纸的设置
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
        .LayoutMode = wdLayoutModeLineGrid
    End With
设定这种页边距的原因是:让每页纸上有两图和文字
'*************************************************
'自动加入图片
Dim arr(1 To 100)
Dim i As Long
Dim j As String
Dim x As String
Dim y As String
Dim z As String
Dim a As String
Dim xlsname As String

y = "\*.jpg"
z = "\"
x = address.Value
a = number.Value
窗体第一个文本框名称设为 address  , 第二个文本框名称设置为 number
            xlsname = Dir("" & x & y)      
'这句的意思是:查询文件夹所在地址, 用   "" & x & y  来表示文件夹地址,例如:输入  d:\123  ,x获得输入值,然后在和y的值组合下:就变成 d:\123 \*.jpg,一看就熟悉,就是代表查找 123文件夹里面的jpg格式的文件,
        For i = 1 To a
                If xlsname = "" Then
                        Exit For
                End If
                    arr(i) = xlsname
把图片名称放入数组:arr(i)
                    xlsname = Dir
然后循环查询完所有的图片
下面这段估计很多人有疑惑,不着急,先看看我们要实现什么功能:让图片按顺序插入进去,但是,我看了一些帖子表示,利用word插入功能批量按顺序插入图片的时候,并不能按顺序放入图片,如果按名称排列好,按一般情况来选择,是从第一个图片,选到最后一个图片,但是你插入的是,你就会发现,第一章图片,被放到整篇文档的最后,所以为了避免这一点,我就跳过第一页的图片(第一页有两张图片,我默认为一组,所以写程序的时候跳过的是两张图片,看   If i > 2 Then    这个条件你就明白我在说什么了),从第二页开始插入
If i > 2 Then
'        Next i
'    For i = 0 To 11
         j = arr(i)
数组的每个元素(文件名)循环改变 j 的值
    Selection.InlineShapes.AddPicture FileName:= _
        "" & x & z & j, LinkToFile:=False, SaveWithDocument:= _
        True
这段代码就是增加图片的    & x & z & j   这个也是地址,读者可以依照上面的方法,自己拼出来,就明白了.
    Selection.TypeParagraph
插入一张图片后换行
   Selection.TypeText Text:=j
在把数组的名称放到输出到文档中.
    Selection.TypeParagraph
   End If
    Next i
循环结束后,我们还差第一组图片没有插入,这里开始补回来
            xlsname = Dir("" & x & y)
        For i = 1 To a
                If xlsname = "" Then
                        Exit For
                End If
                    arr(i) = xlsname
                    xlsname = Dir
If i < 3 Then
'        Next i
'    For i = 0 To 11
         j = arr(i)
    Selection.InlineShapes.AddPicture FileName:= _
        "" & x & z & j, LinkToFile:=False, SaveWithDocument:= _
        True
    Selection.TypeParagraph
   Selection.TypeText Text:=j
    Selection.TypeParagraph
   End If
    Next i
结束循环
    Selection.TypeBackspace
这句话,呵呵,看看循环完成后,会多按一个回车,我把他删除掉.读者试试不要这句代码,你就能看出不同来
'*************************************************
由于dir查询的是,会把文件名和扩展名一起传到数组里面,所以在利用上面    Selection.TypeText Text:=j   语句输出的时候,会有   .jpg   跟在名称后面,我们要去掉它,就用word的替换功能,   ctrl+h  我相信大家都对这个快捷键不陌生吧.
'删除文件名后面的".jpg"
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ".jpg"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
'*************************************************
这里是删除排序数字的.
你输入的图片数量 传给了变量 a   然后用循环  从0开始循环一直到 a  例如你输入了  10   ,表示有10张图片,  循环从  0   到  10   查询文章中出现的0 到10 的数字,全部替换掉,这也用到了替换功能  
'删除文件名字里面的数字
For i = 0 To a
Select Case number.Value
Case i = i
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "" & i
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    End Select
    Next i
'*************************************************
'居中排列,黑体,四号字
    Selection.WholeStory
    Selection.Font.Size = 14
    Selection.Font.Name = "黑体"
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter

'*************************************************
'所有图片设定同比例大小
    Mywidth = 16 '16为图片宽度(厘米)
    Myheigth = 12 '12为图片高度(厘米)
    For Each iShape In ActiveDocument.InlineShapes
    iShape.Height = 28.345 * Myheigth
    iShape.Width = 28.345 * Mywidth
    Next iShape
   
End Sub
上传了自己做的窗体文件,供大家学习,玩玩
如果想word打开的时候自动运行窗体文件,就vba里新插入模块
入代码:
Sub autoopen()
UserForm1.Show 0
End Sub
关闭word 再打开word看看吧.哈哈

非常感谢  
cbtaja   的提点,  我的求助帖在http://club.excelhome.net/forum.php?mod=viewthread&tid=798165&page=1#pid5460444
程序有很多冗余,希望高手来提点下,改的精炼点,写代码很简单,但是要写高效的代码,确实需要一定的水平,我只是菜鸟,还在努力......还在学习......

ps:写好了帖子,但是发布的时候出了好多错误,回头一看发布了好多条重复的,希望版主处理下.



窗体文件.rar

2.6 KB, 下载次数: 790

TA的精华主题

TA的得分主题

发表于 2011-12-5 22:25 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
新人报到  
给顶一个先  
谁说我什么都不懂啊
还是我叫你整合的呢
不过这个小东西确实很方便
有兴趣的可以试用看看

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-12-5 22:28 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
水清楚 发表于 2011-12-5 22:25
新人报到  
给顶一个先  
谁说我什么都不懂啊

好吧,我的解释你看懂了吗?

TA的精华主题

TA的得分主题

发表于 2011-12-5 23:37 | 显示全部楼层
惭愧啊,代码运行出错,窗体不知道怎样用

TA的精华主题

TA的得分主题

 楼主| 发表于 2011-12-6 06:01 | 显示全部楼层
本帖最后由 维所慾維 于 2011-12-6 06:02 编辑
szqhb 发表于 2011-12-5 23:37
惭愧啊,代码运行出错,窗体不知道怎样用


在vb里面如图 5.jpg 导入就可以了,有空在试试看吧

TA的精华主题

TA的得分主题

发表于 2011-12-6 08:35 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2011-12-6 09:07 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2011-12-6 10:45 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
厉害啊,学习啊!买本书啃了…

TA的精华主题

TA的得分主题

发表于 2011-12-6 11:40 | 显示全部楼层
楼主,请把黄色底色的内容直接注释掉吧,好让我们复制过来就可以用啊!
6楼的建议很好啊,看看是否可以修改一下

TA的精华主题

TA的得分主题

发表于 2011-12-6 14:37 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-14 00:21 , Processed in 0.055321 second(s), 9 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表