主题：[求助]合并Word

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

谢谢！

可以了。谢谢蓝老师！

我想增加一种功能，就是把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

For bb = 0 To ere
        nn = tr.Nodes(bb)
                  wapp1.ActiveWindow.Selection.WholeStory

            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