Word中自动批量插入图片的VBA代码

为了赶编一个图册,我们定了一个图片格式,图片全部存在硬盘上,每个图片均有一定的编号,如果手工实现,至少要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

NumRows:=2, myTable =

NumColumns:=3,

ActiveDocument.Tables.Add(Range:=Selection.Range, _ 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

ntal, 71, 35, 172, 36)

myTB1.TextFrame.TextRange = str1(1) & Chr(13) & \"部件编码:\" & str1(0)

Set

ntal, 609, 509, 165, 22)

myTB2.TextFrame.TextRange = \"XXXXXXXXX 2007年7月\"

'Set arrPic = ActiveDocument.Shapes.AddPicture(\"D:\\我的文档\\My Pictures\\88888\\arrow.gif\

Selection.MoveDown Unit:=wdLine, Count:=2 Selection.TypeParagraph Loop Close End Sub Sub sx() '

' sx Macro

' 宏在 2007-7-18 由 zwx 创建 '

myTB2

=

ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizo

myTB1

=

ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizo

Dim tmp As String, FileNumber As Integer

Set fs = CreateObject(\"Scripting.FileSystemObject\") Set a = fs.CreateTextFile(\"c:\\Errmeilan.txt\Set b = fs.CreateTextFile(\"c:\\OKmeilan.txt\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