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

   为了赶编一个图册,我们定了一个图片格式,图片全部存在硬盘上,每个图片均有一定的编号,如果手工实现,至少要24小时以上,中间还会出现DOC文件澎湃死机,想起来头就大.根据工作的流程,定了个索引文件格式,写了个VBA脚本,实现了(1)在WORD中插入表格(关键是单元格合并);(2)在WORD中插入文本框(浮于表格与图片上);(3)定义索引文件的格式(编号\图片\说明);(4)在WORD中读取索引文件格式.

  结果,完成一个图册文件的制作,只用了不到20分钟,真是轻松.在工作有好的帮手真的非常重要,thankQCJ.下面是它的VBA代码,等到有时间时,用VC把它实现打包,让更多的人更简单地用吧.

==================================

Subtest()
'
' test Macro
' 宏在 2007-7-16 由 FtpDown 录制

'插入表格
    Dim filenameAs String, str1() As String, tmp As String, i As Integer
    Dim photoimgAs String, gisimg As String
   
    filename ="c:\set.txt" '这里是文本文件所在路径位置
    Openfilename For Input As 1
    Do UntilEOF(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.AddPicturefilename:= _
       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.AddPicturefilename:= _
       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.AddPicturefilename:= _
       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:\我的文档\MyPictures\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"
   
    Iffs.FileExists(photoimg) = True And fs.FileExists(gisimg) = TrueThen
      b.writeLine (tmp)
   Else
      a.writeLine (tmp)
    EndIf
Loop
a.Close
b.Close
Set fs = Nothing
Set a = Nothing
Set b = Nothing
End Sub