Foxtable(狐表)用户栏目专家坐堂 → [求助]求合并三段代码


  共有2786人关注过本帖树形打印复制链接

主题:[求助]求合并三段代码

帅哥哟,离线,有人找我吗?
jyh7081
  1楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:四尾狐 帖子:962 积分:8505 威望:0 精华:0 注册:2012/10/3 13:25:00
[求助]求合并三段代码  发帖心情 Post By: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    '光标移至文首


 回到顶部
帅哥哟,离线,有人找我吗?
大红袍
  2楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:贵宾 帖子:39310 积分:196782 威望:0 精华:1 注册:2015/4/25 9:23:00
  发帖心情 Post By: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
  3楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:四尾狐 帖子:962 积分:8505 威望:0 精华:0 注册:2012/10/3 13:25:00
  发帖心情 Post By: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( "生成完毕!")'

 回到顶部
帅哥哟,离线,有人找我吗?
大红袍
  4楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:贵宾 帖子:39310 积分:196782 威望:0 精华:1 注册:2015/4/25 9:23:00
  发帖心情 Post By:2016/8/28 17:18:00 [只看该作者]

Dim tb As Table, r As Row

 

改成

 

Dim tb As Object, r As Object


 回到顶部
帅哥哟,离线,有人找我吗?
jyh7081
  5楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:四尾狐 帖子:962 积分:8505 威望:0 精华:0 注册:2012/10/3 13:25:00
  发帖心情 Post By: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




 回到顶部
帅哥哟,离线,有人找我吗?
大红袍
  6楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:贵宾 帖子:39310 积分:196782 威望:0 精华:1 注册:2015/4/25 9:23:00
  发帖心情 Post By: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
  7楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级:四尾狐 帖子:962 积分:8505 威望:0 精华:0 注册:2012/10/3 13:25:00
  发帖心情 Post By:2016/8/29 11:34:00 [只看该作者]

谢谢版主!

 回到顶部