Word中自动批量插入图片的VBA代码
2007-08-22 09:18阅读：
为了赶编一个图册,我们定了一个图片格式,图片全部存在硬盘上,每个图片均有一定的编号,如果手工实现,至少要24小时以上,中间还会出现DOC文件澎湃死机,想起来头就大.根据工作的流程,定了个索引文件格式,写了个VBA脚本,实现了(1)在WORD中插入表格(关键是单元格合并);(2)在WORD中插入文本框(浮于表格与图片上);(3)定义索引文件的格式(编号\图片\说明);(4)在WORD中读取索引文件格式.
结果,完成一个图册文件的制作,只用了不到20分钟,真是轻松.在工作有好的帮手真的非常重要,thank
QCJ.下面是它的VBA代码,等到有时间时,用VC把它实现打包,让更多的人更简单地用吧.
==================================
Sub test()
'
' test Macro
' 宏在 2007-7-16 由 FtpDown 录制
'插入表格
Dim filename As String, str1() As String,
tmp As String, i As Integer
Dim photoimg As String, gisimg As
String
filename = 'c:\set.txt'
'这里是文本文件所在路径位置
Open filename For Input As 1
Do Until EOF(1)
Line Input #1, tmp
str1 = Split(tmp, ',')
photoimg = str1(2) &
'\1.jpg'
gisimg = str1(2) & '\2.jpg'
Selection.Collapse
Direction:=wdCollapseStart
Set myTable =
ActiveDocument.Tables.Add(Range:=Selection.Range, _
NumRows:=2, NumColumns:=3,
DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=
_
wdAutoFitFixed)
'修改表格的高宽
myTable.Rows(1).HeightRule =
wdRowHeightAtLeast
myTable.Rows(1).Height =
CentimetersToPoints(8.62)
myTable.Columns(1).PreferredWidthType =
wdPreferredWidthPoints
myTable.Columns(1).PreferredWidth =
CentimetersToPoints(12)
myTable.Columns(2).PreferredWidthType =
wdPreferredWidthPoints
myTable.Columns(2).PreferredWidth =
CentimetersToPoints(0.42)
myTable.Columns(3).PreferredWidthType =
wdPreferredWidthPoints
myTable.Columns(3).PreferredWidth =
CentimetersToPoints(12.32)
myTable.Rows(2).HeightRule =
wdRowHeightAtLeast
myTable.Rows(2).Height =
CentimetersToPoints(8.62)
'合并表格
myTable.Cell(Row:=1, Column:=2).Merge
_
MergeTo:=myTable.Cell(Row:=2,
Column:=2)
myTable.Cell(Row:=1, Column:=3).Merge
_
MergeTo:=myTable.Cell(Row:=2,
Column:=3)
'插入图片
myTable.Cell(Row:=1,
Column:=1).Range.InlineShapes.AddPicture filename:= _
photoimg,
LinkToFile:=False, _
SaveWithDocument:=True
myTable.Cell(Row:=1,
Column:=1).Range.InlineShapes(1).Height = 244.35
myTable.Cell(Row:=1,
Column:=1).Range.InlineShapes(1).Width = 344.25
myTable.Cell(Row:=2,
Column:=1).Range.InlineShapes.AddPicture filename:= _
photoimg,
LinkToFile:=False, _
SaveWithDocument:=True
myTable.Cell(Row:=2,
Column:=1).Range.InlineShapes(1).Height = 244.35
myTable.Cell(Row:=2,
Column:=1).Range.InlineShapes(1).Width = 344.25
myTable.Cell(Row:=1,
Column:=3).Range.InlineShapes.AddPicture filename:= _
gisimg,
LinkToFile:=False, _
SaveWithDocument:=True
myTable.Cell(Row:=1,
Column:=3).Range.InlineShapes(1).Height = 498.7
myTable.Cell(Row:=1,
Column:=3).Range.InlineShapes(1).Width = 344.25
'插入文本框
Set myTB1 =
ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal,
71, 35, 172, 36)
myTB1.TextFrame.TextRange = str1(1) &
Chr(13) & '部件编码:' & str1(0)
Set myTB2 =
ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal,
609, 509, 165, 22)
myTB2.TextFrame.TextRange = 'XXXXXXXXX
2007年7月'
'Set arrPic =
ActiveDocument.Shapes.AddPicture('D:\我的文档\My
Pictures\88888\arrow.gif', False, True, 50, 300)
Selection.MoveDown Unit:=wdLine,
Count:=2
Selection.TypeParagraph
Loop
Close
End Sub
Sub sx()
'
' sx Macro
' 宏在 2007-7-18 由 zwx 创建
'
Dim tmp As String, FileNumber As Integer
Set fs = CreateObject('Scripting.FileSystemObject')
Set a = fs.CreateTextFile('c:\Errmeilan.txt', True)
Set b = fs.CreateTextFile('c:\OKmeilan.txt', True)
filename = 'c:\meilan.txt' '这里是文本文件所在路径位置
FileNumber = FreeFile
Open filename For Input As FileNumber
Do Until EOF(FileNumber)
Line Input #FileNumber, tmp
str1 = Split(tmp, ',')
photoimg = str1(2) & '\001.jpg'
gisimg = str1(2) & '\002.jpg'
If fs.FileExists(photoimg) = True And
fs.FileExists(gisimg) = True Then
b.writeLine
(tmp)
Else
a.writeLine
(tmp)
End If
Loop
a.Close
b.Close
Set fs = Nothing
Set a = Nothing
Set b = Nothing
End Sub
