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

以文本方式查看主题

-  Foxtable(狐表)  (http://www.foxtable.com/bbs/index.asp)
--  专家坐堂  (http://www.foxtable.com/bbs/list.asp?boardid=2)
----  [求助]合并Word  (http://www.foxtable.com/bbs/dispbbs.asp?boardid=2&id=142188)

--  作者：天一生水
--  发布时间：2019/10/20 21:12:00
--  [求助]合并Word
蓝老师好！
我把选中的多个Word文件路径放入目录树中，然后新建一个Word文档接受合并的文件，在合并时，每一个文件后面插入分页符进行分隔。
在运行中提示第一个文件被占用，还有一些其他的问题，请老师帮助看看是哪里的问题？
谢谢！

此主题相关图片如下：截屏图片.jpg

Dim wapp1 As New MSWord.Application
Dim wapp2 As New MSWord.Application
try
\'新建一个Word接收文档
Dim app As New MSWord.Application
Dim missing = System.Reflection.Missing.Value
Dim nDoc = App.Documents.Add(missing, missing, missing, missing)
Dim nm As String = Format(Date.Now, "yyyyMMddhhmmss")
nDoc.SaveAs(ProjectPath & "Word合并\\" & nm & ".doc")
app.quit
\'msgbox("新建word成功")
Dim doc1 = wapp1.Documents.Open(ProjectPath & "Word合并\\" & nm & ".doc")

Dim tr As WinForm.TreeView = e.Form.Controls("TreeView1") \'
Dim nn As WinForm.TreeNode
Dim ere As Integer = tr.Nodes.Count - 1
Dim bb As Integer
For bb = 0 To ere
nn = tr.Nodes(bb)

Dim doc2 = wapp2.Documents.Open(nn.Text)
wapp2.ActiveWindow.Selection.WholeStory
wapp2.ActiveWindow.Selection.copy
wapp1.ActiveWindow.Selection.WholeStory
wapp1.ActiveWindow.Selection.MoveRight(Unit:=1, Count:=1)
\'在文件后插入分页符
If bb > 1 Then
Dim pBreak = MSWord.WdBreakType.wdSectionBreakNextPage
wapp1.ActiveWindow.Selection.InsertBreak(pBreak)
End If

wapp1.ActiveWindow.Selection.paste
Next
wapp2.Quit
wapp1.Visible = True
catch ex As exception
msgbox(ex.message)
wapp1.Quit
wapp2.Quit
finally
End try

--  作者：有点蓝
--  发布时间：2019/10/20 21:19:00
--

Dim wapp1 As New MSWord.Application
Dim wapp2 As New MSWord.Application
try
\'新建一个Word接收文档
Dim missing = System.Reflection.Missing.Value
Dim doc1 = wapp1.Documents.Add(missing, missing, missing, missing)

Dim tr As WinForm.TreeView = e.Form.Controls("TreeView1") \'
Dim nn As WinForm.TreeNode
Dim ere As Integer = tr.Nodes.Count - 1
Dim bb As Integer
For bb = 0 To ere
nn = tr.Nodes(bb)

Dim doc2 = wapp2.Documents.Open(nn.Text)
wapp2.ActiveWindow.Selection.WholeStory
wapp2.ActiveWindow.Selection.copy
wapp1.ActiveWindow.Selection.WholeStory
wapp1.ActiveWindow.Selection.MoveRight(Unit:=1, Count:=1)
\'在文件后插入分页符
If bb > 1 Then
Dim pBreak = MSWord.WdBreakType.wdSectionBreakNextPage
wapp1.ActiveWindow.Selection.InsertBreak(pBreak)
End If

wapp1.ActiveWindow.Selection.paste
Next
wapp2.Quit

Dim nm As String = Format(Date.Now, "yyyyMMddhhmmss")
doc1.SaveAs(ProjectPath & "Word合并\\" & nm & ".doc")
wapp1.Visible = True
catch ex As exception
msgbox(ex.message)

finally
wapp1.Quit
wapp2.Quit
End try

--  作者：天一生水
--  发布时间：2019/10/20 21:39:00
--
谢谢老师！
提示“命令失败”

下载信息  [文件大小：   下载次数： ]
点击浏览该文件:合并word测试.rar

--  作者：天一生水
--  发布时间：2019/10/21 11:25:00
--

麻烦蓝老师看看是什么原因？

谢谢！

--  作者：有点蓝
--  发布时间：2019/10/21 13:41:00
--

Dim wapp1 As New MSWord.Application
Dim wapp2 As New MSWord.Application
try
\'新建一个Word接收文档
Dim missing = System.Reflection.Missing.Value
Dim doc1 = wapp1.Documents.Add(missing, missing, missing, missing)

Dim tr As WinForm.TreeView = e.Form.Controls("TreeView1") \'
Dim nn As WinForm.TreeNode
Dim ere As Integer = tr.Nodes.Count - 1
Dim bb As Integer
For bb = 0 To ere
nn = tr.Nodes(bb)
wapp1.ActiveWindow.Selection.WholeStory
wapp1.ActiveWindow.Selection.MoveRight(Unit:=1, Count:=1)
\'在文件后插入分页符
If bb > 1 Then
Dim pBreak = MSWord.WdBreakType.wdSectionBreakNextPage
wapp1.ActiveWindow.Selection.InsertBreak(pBreak)
End If

Dim doc2 = wapp2.Documents.Open(nn.Text)
wapp2.ActiveWindow.Selection.WholeStory
wapp2.ActiveWindow.Selection.copy

wapp1.ActiveWindow.Selection.paste
Next
Dim nm As String = Format(Date.Now, "yyyyMMddhhmmss")
doc1.SaveAs(ProjectPath & "Word合并\\" & nm & ".doc")
wapp1.Visible = True
catch ex As exception
msgbox(ex.message)
finally
wapp2.Quit
End try

--  作者：天一生水
--  发布时间：2019/10/21 16:49:00
--

可以了。谢谢蓝老师！

我想增加一种功能，就是把Word、execl文件混合添加到目录树，然后按照目录树中的排序合并到一个Word文档中，每个文件后面添加分页符。

里面的关系有点分辨不清，请蓝老师帮助指导。谢谢！

Dim wapp1 As New MSWord.Application
Dim wapp2 As New MSWord.Application
Dim wapp3 As New MSExcel.Application       ’execl文档
try
    \'新建一个Word接收文档
    Dim missing = System.Reflection.Missing.Value
    Dim doc1 = wapp1.Documents.Add(missing, missing, missing, missing)

    Dim tr As WinForm.TreeView = e.Form.Controls("TreeView1")    \'
    Dim nn As WinForm.TreeNode
    Dim ere As Integer = tr.Nodes.Count - 1
    Dim bb As Integer
    For bb = 0 To ere
        nn = tr.Nodes(bb)

        If FileSys.GetName(nn.Text).split(".")(0) = "doc" Then    \'如果是doc文件
            wapp1.ActiveWindow.Selection.WholeStory
            wapp1.ActiveWindow.Selection.MoveRight(Unit:=1, Count:=1)
            \'在文件后插入分页符
            If bb > 0 Then
                Dim pBreak = MSWord.WdBreakType.wdSectionBreakNextPage
                wapp1.ActiveWindow.Selection.InsertBreak(pBreak)
            End If

            Dim doc2 = wapp2.Documents.Open(nn.Text)
            wapp2.ActiveWindow.Selection.WholeStory
            wapp2.ActiveWindow.Selection.copy

            wapp1.ActiveWindow.Selection.paste
        End If

        If FileSys.GetName(nn.Text).split(".")(0) = "xls" Then    \'如果是xls文件
            Dim Wb As MSExcel.WorkBook = App2.WorkBooks.Open(nn.Text)
            Dim Ws As MSExcel.WorkSheet = Wb.WorkSheets(1) \'指定要复制的工作表
            Ws.UsedRange.Copy
            wb.saved = True
            wapp3.DisplayAlerts = False

            wapp.ActiveWindow.Selection.WholeStory
            wapp.Selection.MoveRight(Unit:=1)
            wapp.Selection.TypeText(Text:=vbcrlf)
            wapp.ActiveWindow.Selection.paste

            wapp3.Quit
            .........

        End If
    Next
    Dim nm As String = Format(Date.Now, "yyyyMMddhhmmss")
    doc1.SaveAs(ProjectPath & "Word合并\\" & nm & ".doc")
    wapp1.Visible = True
catch ex As exception
    msgbox(ex.message)
finally
    wapp2.Quit
End try

--  作者：有点蓝
--  发布时间：2019/10/21 17:11:00
--

For bb = 0 To ere
        nn = tr.Nodes(bb)
              wapp1.ActiveWindow.Selection.WholeStory
            wapp1.ActiveWindow.Selection.MoveRight(Unit:=1, Count:=1)
            \'在文件后插入分页符
            If bb > 0 Then
                Dim pBreak = MSWord.WdBreakType.wdSectionBreakNextPage
                wapp1.ActiveWindow.Selection.InsertBreak(pBreak)
End If
        If FileSys.GetName(nn.Text).split(".")(0) = "doc" Then    \'如果是doc文件

            Dim doc2 = wapp2.Documents.Open(nn.Text)
            wapp2.ActiveWindow.Selection.WholeStory
            wapp2.ActiveWindow.Selection.copy

            wapp1.ActiveWindow.Selection.paste
        End If
If FileSys.GetName(nn.Text).split(".")(0) = "xls" Then    \'如果是xls文件
            Dim Wb As MSExcel.WorkBook = wapp3 .WorkBooks.Open(nn.Text)
            Dim Ws As MSExcel.WorkSheet = Wb.WorkSheets(1) \'指定要复制的工作表
            Ws.UsedRange.Copy
            wb.saved = True
            wapp3.DisplayAlerts = False
  wapp1.ActiveWindow.Selection.paste
        End If

……
finally
    wapp2.Quit
wapp3.Quit

--  作者：天一生水
--  发布时间：2019/10/21 19:08:00
--

提示如下，请老师指教。
谢谢！

此主题相关图片如下：截屏图片 (1).jpg

下载信息  [文件大小：   下载次数： ]
点击浏览该文件:合并word文档测试.rar

代码如下：
Dim wapp1 As New MSWord.Application
Dim wapp2 As New MSWord.Application
Dim wapp3 As New MSExcel.Application
try
\'新建一个Word接收文档
Dim missing = System.Reflection.Missing.Value
Dim doc1 = wapp1.Documents.Add(missing, missing, missing, missing)

Dim tr As WinForm.TreeView = e.Form.Controls("TreeView1") \'
Dim nn As WinForm.TreeNode
Dim ere As Integer = tr.Nodes.Count - 1
Dim bb As Integer
For bb = 0 To ere
nn = tr.Nodes(bb)
wapp1.ActiveWindow.Selection.WholeStory
wapp1.ActiveWindow.Selection.MoveRight(Unit:=1, Count:=1)

\'在文件后插入分页符
If bb > 0 Then
Dim pBreak = MSWord.WdBreakType.wdSectionBreakNextPage
wapp1.ActiveWindow.Selection.InsertBreak(pBreak)
End If

If FileSys.GetName(nn.Text).split(".")(0) = "doc" Or FileSys.GetName(nn.Text).split(".")(0) = "docx" Then \'如果是doc文件
Dim doc2 = wapp2.Documents.Open(nn.Text)
wapp2.ActiveWindow.Selection.WholeStory
wapp2.ActiveWindow.Selection.copy
wapp1.ActiveWindow.Selection.paste
End If

If FileSys.GetName(nn.Text).split(".")(0) = "xls" Or FileSys.GetName(nn.Text).split(".")(0) = "xlsx" Then \'如果是xls文件
Dim Wb As MSExcel.WorkBook = wapp3 .WorkBooks.Open(nn.Text)
Dim Ws As MSExcel.WorkSheet = Wb.WorkSheets(1) \'指定要复制的工作表
Ws.UsedRange.Copy
wb.saved = True
wapp3.DisplayAlerts = False
wapp1.ActiveWindow.Selection.paste
End If
Next

Dim nm As String = Format(Date.Now, "yyyyMMddhhmmss")
doc1.SaveAs(ProjectPath & "Word合并\\" & nm & ".docx")
wapp1.Visible = True
catch ex As exception
msgbox(ex.message)
finally
wapp2.Quit
wapp3.Quit
End try

--  作者：有点蓝
--  发布时间：2019/10/21 20:44:00
--
试试

If FileSys.GetName(nn.Text).split(".")(0) = "xls" Or FileSys.GetName(nn.Text).split(".")(0) = "xlsx" Then \'如果是xls文件
Dim Wb As MSExcel.WorkBook = wapp3 .WorkBooks.Open(nn.Text)
Dim Ws As MSExcel.WorkSheet = Wb.WorkSheets(1) \'指定要复制的工作表
Ws.UsedRange.Copy
wapp1.ActiveWindow.Selection.TypeParagraph
wapp1.ActiveWindow.Selection.paste
End If

--  作者：天一生水
--  发布时间：2019/10/21 20:59:00
--
还是一样的提示