以文本方式查看主题

-  Foxtable(狐表)  (http://foxtable.net/bbs/index.asp)
--  专家坐堂  (http://foxtable.net/bbs/list.asp?boardid=2)
----  [求助]合并Word  (http://foxtable.net/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
--  
还是一样的提示