专家坐堂-[求助]求合并三段代码Foxtable(狐表) - 新一代数据库软件，完美融合Access、Foxpro、Excel、vb.net之优势，人人都能掌握的快速软件开发工具!

以文本方式查看主题

-  Foxtable(狐表)  (http://foxtable.net/bbs/index.asp)
--  专家坐堂  (http://foxtable.net/bbs/list.asp?boardid=2)
----  [求助]求合并三段代码  (http://foxtable.net/bbs/dispbbs.asp?boardid=2&id=89712)

--  作者：jyh7081
--  发布时间：2016/8/27 17:38:00
--  [求助]求合并三段代码

第一、二段代码可在foxtable中分别独立运行，但没有衔接好；第三段代码是word中的VBA代码，不知如何加进来，请帮忙，谢谢！
附件：
下载信息  [文件大小：   下载次数： ]
点击浏览该文件:aa.rar

\'第一段代码:写入word模板,生成word报表:

Dim clbx1 As WinForm.CheckedListBox = e.Form.Controls("CheckedListBox1")
Dim clbx2 As WinForm.CheckedListBox = e.Form.Controls("CheckedListBox2")

For Each j As String In clbx2.CheckedIndices
Dim tm As String = ProjectPath & "模板文件\\" & clbx2.Items(j) \'指定模板文件
For Each i As Integer In clbx1.CheckedIndices
Dim fl As String = ProjectPath & "成品文件\\" & clbx1.items(i) & clbx2.Items(j) \'指定目标文件

\'文件已经存在,是否覆盖重新填写
If FileSys.FileExists(fl) Then
If MessageBox.Show(fl & "文件已经存在,是否覆盖重新填写?","提示", MessageBoxButtons.YesNo, MessageBoxIcon.Question) = DialogResult.No Then
Continue For
End If
End If
Dim nm As String = CurrentTable.Name
Dim dr As DataRow =DataTables(nm).Find("名称 = \'" & clbx1.items(i) & "\'")

\'写入模板
If dr IsNot Nothing
Dim wrt As New WordReport(Tables(nm),tm,fl) \'定义一个WordReport
wrt.BuildOne(dr)
wrt.quit
End If
Next
Next

\'第二段代码，删除生成的word报表中的空行:
Dim app As New MSWord.Application
try
Dim doc = app.Documents.Open("fl")
For Each k As object In doc.Paragraphs
If Len(Trim(k.Range.text)) = 1 Then k.Range.Delete
Next
doc.save
app.quit
catch ex As exception
msgbox(ex.message)
app.quit
End try

\'第三段代码,word报表重新排版:
\'删除手动换行符和假段落标记----这两句放到删除空行之前，
ActiveDocument.Content.Find.Execute FindText:="^l", replacewith:="^p", Replace:=wdReplaceAll
ActiveDocument.Content.Find.Execute FindText:="^13", replacewith:="^p", Replace:=wdReplaceAll

\'取消缩进，重新缩进，
Selection.WholeStory \'全选
With Selection.ParagraphFormat \'选定区域段落设置
.CharacterUnitFirstLineIndent = 0 \'取消首行缩进
.FirstLineIndent = CentimetersToPoints(0)
.CharacterUnitLeftIndent = 2 \'左缩进2字符
End With
Selection.HomeKey unit:=wdStory \'光标移至文首

--  作者：大红袍
--  发布时间：2016/8/28 12:53:00
--

\'第一段代码:写入word模板,生成word报表:

Dim clbx1 As WinForm.CheckedListBox = e.Form.Controls("CheckedListBox1")
Dim clbx2 As WinForm.CheckedListBox = e.Form.Controls("CheckedListBox2")

For Each j As String In clbx2.CheckedIndices
    Dim tm As String = ProjectPath & "模板文件\\" & clbx2.Items(j) \'指定模板文件
    For Each i As Integer In clbx1.CheckedIndices
        Dim fl As String = ProjectPath & "成品文件\\" & clbx1.items(i) & clbx2.Items(j)      \'指定目标文件

        \'文件已经存在,是否覆盖重新填写
        If FileSys.FileExists(fl) Then
            If MessageBox.Show(fl & "文件已经存在,是否覆盖重新填写?","提示", MessageBoxButtons.YesNo, MessageBoxIcon.Question) = DialogResult.No Then
                Continue For
            End If
        End If
        Dim nm As String = CurrentTable.Name
        Dim dr As DataRow =DataTables(nm).Find("名称 = \'" & clbx1.items(i) & "\'")
        \'
        If dr IsNot Nothing
            Dim wrt As New WordReport(Tables(nm),tm,fl) \'定义一个WordReport
            wrt.BuildOne(dr)
            wrt.quit
            Dim app As New MSWord.Application
            try
                Dim doc = app.Documents.Open(fl)
                For Each k As object In doc.Paragraphs
                    If Len(Trim(k.Range.text)) = 1 Then k.Range.Delete
                Next
                doc.Content.Find.Execute(FindText:="^l", replacewith:="^p", Replace:=2)
                doc.Content.Find.Execute(FindText:="^13", replacewith:="^p", Replace:=2)
                app.Selection.WholeStory   \'全选
                With app.Selection.ParagraphFormat \'选定区域段落设置
                    .CharacterUnitFirstLineIndent = 0   \'取消首行缩进
                    .FirstLineIndent = 0
                    .CharacterUnitLeftIndent = 2   \'左缩进2字符
                End With
                app.Selection.HomeKey(unit:=6)    \'光标移至文首
                doc.save
                app.quit
            catch ex As exception
                msgbox(ex.message)
                app.quit
            End try
        End If
    Next
Next

--  作者：jyh7081
--  发布时间：2016/8/28 17:08:00
--

版主，经过一下午的调试，没有出现问题。太感谢了！

还有个问题，当word报表是表格时，如果存在空表行需要删除，我加了一段代码（在word的可有效运行的VBA），并进行了修改，但还有是不能运行，请老师再给看看（加黑部分代码）：

\'\'\'
\'word报表:带表格
Dim clbx1 As WinForm.CheckedListBox = e.Form.Controls("CheckedListBox1")
Dim clbx2 As WinForm.CheckedListBox = e.Form.Controls("CheckedListBox2")
For Each j As String In clbx2.CheckedIndices
Dim tm As String = ProjectPath & "模板文件\\" & clbx2.Items(j) \'指定模板文件
For Each i As Integer In clbx1.CheckedIndices
Dim fl As String = ProjectPath & "成品文件\\" & clbx1.items(i) & clbx2.Items(j) \'指定目标文件

\'文件已经存在,是否覆盖重新填写
If FileSys.FileExists(fl) Then
If MessageBox.Show(fl & "文件已经存在,是否覆盖重新填写?","提示", MessageBoxButtons.YesNo, MessageBoxIcon.Question) = DialogResult.No Then
Continue For
End If
End If
Dim nm As String = CurrentTable.Name
Dim dr As DataRow =DataTables(nm).Find("案号 = \'" & clbx1.items(i) & "\'")

If dr IsNot Nothing
Dim wrt As New WordReport(Tables(nm),tm,fl) \'定义一个WordReport
wrt.BuildOne(dr)
wrt.quit

Dim app As New MSWord.Application
try
Dim doc = app.Documents.Open(fl)
doc.Content.Find.Execute(FindText:="^l", replacewith:="^p", Replace:=2)
doc.Content.Find.Execute(FindText:="^13", replacewith:="^p", Replace:=2)

\'删除表格空行：
Dim tb As Table, r As Row
With doc
For Each tb In .Tables
For Each r In tb.Rows
r.Range.Find.Execute(FindText:="^l", replacewith:="^p", Replace:=2)
r.Range.Find.Execute(FindText:=" ", replacewith:="", Replace:=2)
r.Range.Find.Execute(FindText:="^w", replacewith:="", Replace:=2)
If Len(Replace(Replace(r.Range.Text, vbCr, ""), Chr(7), "")) = 0 Then r.Delete
Next
Next
End With

doc.save
app.quit
catch ex As exception
msgbox(ex.message)
app.quit
End try
End If
Next
Next
MessageBox.Show( "生成完毕!")\'

--  作者：大红袍
--  发布时间：2016/8/28 17:18:00
--

Dim tb As Table, r As Row

改成

Dim tb As Object, r As Object

--  作者：jyh7081
--  发布时间：2016/8/28 20:08:00
--
版主，还有一个问题：有一种换行符没有替换掉（狐表单元格内的Ctrl+回车产生的），在word报表中可以用删除行代码去掉它，vba代码如下：

Sub 删除空行()
Dim i As Paragraph
For Each i In ActiveDocument.Paragraphs
i.Range.Select
If Len(i.Range) = 1 Then i.Range.Delete
Do
If Selection.Characters(1).Text = Chr(10) Then Selection.Characters(1).Delete
Loop Until Selection.Characters(1).Text <> Chr(10)
Next
End Sub

我改成狐表中的代码，但显示“类型不匹配”，麻烦你再给看看，谢谢！
’ 删除空行
For Each k As object In doc.Paragraphs
k.Range.Select
If Len(k.Range) = 1 Then k.Range.Delete
Do
If app.Selection.Characters(1).Text = Chr(10) Then app.Selection.Characters(1).Delete
Loop Until app.Selection.Characters(1).Text <> Chr(10)
Next

--  作者：大红袍
--  发布时间：2016/8/29 9:48:00
--

                For Each k As object In doc.Paragraphs
                    k.Range.Select
                    If Len(k.Range.Text) = 1 Then k.Range.Delete
                    Do
                        If app.Selection.Characters(1).Text = Chr(10) Then app.Selection.Characters(1).Delete
                    Loop Until app.Selection.Characters(1).Text <> Chr(10)
                Next

--  作者：jyh7081
--  发布时间：2016/8/29 11:34:00
--
谢谢版主！