主题：Foxtable操控Word的代码（测试成功，分享大家）

 

'操控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

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