主题：Word报表与邮件合并相结合生成Word报表

 前段时间介绍了通过fox操控word直接生成word报表，但是出现了一个问题，字符超过255字时，不能正常，现在通过测试，把fox直接操控word和邮件合并方式相结合可生成word报表，代码分享如下：

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

'*******************************

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

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

Dim Ctn As String = "干部信息"  '当前表表名,通用格式Functions.Execute("CurrentTableName")

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

 

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

'*******************************

 

on error resume Next

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

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

End If

Dim App As New MSWord.Application    '定义MSWord

 

'获得模版

FileSys.CopyFile(ProjectPath & "Attachments\" & FileName, ProjectPath & "Reports\" & FileName,True)

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

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

rng.Select()   '全选

rng.Copy()   '拷贝

nDoc.Activate()

 

'插入文段

 

'***********************************************

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

 

 

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)

 

 

App.Selection.Find.ClearFormatting()

App.Selection.Find.Text = "《出生年月》"

App.Selection.Find.Replacement.ClearFormatting()

If cr.IsNull("出生年月") = False Then

    App.Selection.Find.Replacement.Text = Format(cr("出生年月"),"yyyy.MM")

Else

    App.Selection.Find.Replacement.Text = ""

End If

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

 

App.Selection.Find.ClearFormatting()

App.Selection.Find.Text = "《年龄》"

App.Selection.Find.Replacement.ClearFormatting()

If cr.IsNull("年龄") = False Then

    App.Selection.Find.Replacement.Text = Format(cr("年龄"),"0")

Else

    App.Selection.Find.Replacement.Text = ""

End If

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.Select()

End If

 

 

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

'**********************************************

 

If Tb.Rows.Count > 0 Then

    Dim Book As New XLS.Book(ProjectPath & "Attachments\Word任免审批表数据源.xls")

    Dim fl As String = ProjectPath & "Reports\Word任免审批表数据源.xls"

    Book.Build() '生成细节区

    Book.Save(fl) '保存工作簿

End If

 

nDoc.Activate()

nDoc.MailMerge.OpenDataSource(Name:= ProjectPath & "Reports\Word任免审批表数据源.xls",SQLStatement:="SELECT * FROM `干部信息$`")   '链接数据源

App.Documents.Open(ProjectPath & "Reports\" & FileName)   '再次打开Word模版

nDoc.MailMerge.Execute()

nDoc.Close(False)