|
|
本帖最后由 维所慾維 于 2011-12-5 22:10 编辑
经过几天的实验,今天终于弄好了.为什么弄这个程序,都是因为年底,工作总结的时候,需要插入一年工作中收集的图片,然后打印出来做存底资料.还要按照一定的顺序插入.
好让我来分享下我的小小成果吧:
我家宝贝给它取了个惊讶的名字:小三之黑板报1号
其实她什么都不懂,呵呵,但是是我灵感的源泉,我也不知道为什么,反正就是弄出来了.
先上源代码(全部复制出来,逐一分析),之后有附件,直接下载使用就好了,不用到文章复制了.
ps:其实写代码很简单,就看你有没有耐心去想,遇到问题,能不能分段处理解决,然后把所有功能整合起来,然后在把调试好的程序,用窗体表现出来,就可以给大众用了.
我的程序做了个窗体:
我想让下面文件夹的文件所有图片,包括名字自动插入word里面
名称中1,2,3使用来排序的,输入word里面后的文字要去除排序用的数字
然后在窗体里面写入文件夹所在地址,输入进去,其实可以不要输入,直接打开文件夹后,复制地址栏的路径就可以了,然后运行就得到下图效果:
ps:都是按照文件名排序过去的
下面是运行按钮里面的程序(每段功能都有意识的分开了):
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:写好了帖子,但是发布的时候出了好多错误,回头一看发布了好多条重复的,希望版主处理下.
|
|
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2011-12-5 21:45
楼主
