插入图片，制成图册

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