\'操控Word文档,主要是文档合并

\'*******************************

\'*********以下代码可修改**********

Dim FileName = "任免审批表.doc"   \'定义模版文件名

Dim Ctn As String = "EmptyTable"  \'当前表表名

Dim Tb As Table = Tables(Ctn)   \'定义当前表.

\'*********以上代码可修改**********

\'*******************************

If FileSys.DirectoryExists(ProjectPath & "Reports\\") = False Then   \'如果Reports文件夹不存在

    FileSys.CreateDirectory(ProjectPath & "Reports\\")    \'创建Reports文件夹

End If

Dim App As New MSWord.Application    \'定义MSWord

Try

    \'获得模版

    Dim nDoc = App.Documents.Open(ProjectPath & "Attachments\\" & FileName)

    Dim rng As MSWord.Range = App.Documents(FileName).Range

    rng.Select()   \'全选

    rng.Copy()   \'拷贝

    nDoc.Activate()

    \'插入文段

    Dim idx As Integer = 0

    If Tb.Rows.Count > 0 Then

        For i As Integer = Tb.TopPosition To Tb.BottomPosition

            Dim cr As Row = Tb.Rows(i)

            If idx >= 1 Then

                rng = nDoc.Range(start:=0, End:=0)  \'从前面粘贴

                rng.Paste

            End If

            \'***********************************************

            \'*********以下是代码主体部分,需要修改**********

            App.Selection.Find.ClearFormatting()

            App.Selection.Find.Text = "《姓名》"

            App.Selection.Find.Replacement.ClearFormatting()

            App.Selection.Find.Replacement.Text = cr("姓名")

            App.Selection.Find.Execute(Replace:=MSWord.WdReplace.wdReplaceAll)

            rng.Find.ClearFormatting()

            If rng.Find.Execute("《照片》") Then

                rng.Select()

                If FileSys.FileExists(ProjectPath & "Attachments\\" & cr("图片")) Then

                    App.Selection.InlineShapes.AddPicture(ProjectPath & "Attachments\\" & cr("图片"))

                End If

                rng = App.Documents(FileName).Range

                \'rng.SetRange(start:=0, End:=count)

                rng.Select()

            End If

            \'*********以上是代码主体部分,需要修改**********

            \'**********************************************

            idx += 1

        Next

    End If

    nDoc.SaveAs(ProjectPath & "Reports\\" & FileName)

Catch ex As exception

    msgbox(ex.message)

Finally

    App.Quit

End Try

Dim Proc As New Process

Proc.File = ProjectPath & "Reports\\" & FileName

Proc.Start

 以上代码经过测试基本 成功。分享大家。

没有实例也顶，

如有实例再顶。

http://www.foxtable.com/bbs/dispbbs.asp?boardid=2&Id=27937&page=4

例子这儿有，只需要把替换的诸如："《姓名》" cr(“姓名”)替换掉，把上述代码放到按钮中即可

App.Selection.Find.ClearFormatting()

            App.Selection.Find.Text = "《简历》"

            App.Selection.Find.Replacement.ClearFormatting()

            App.Selection.Find.Replacement.Text = cr("简历")

            App.Selection.Find.Execute(Replace:=MSWord.WdReplace.wdReplaceAll)

简历太长时，不能正常替换，估计与Text有关，如何解决，请那位指导