以文本方式查看主题 - 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文档接受合并的文件,在合并时,每一个文件后面插入分页符进行分隔。 在运行中提示第一个文件被占用,还有一些其他的问题,请老师帮助看看是哪里的问题? 谢谢! 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 -- 谢谢老师! 提示“命令失败” |
-- 作者:天一生水 -- 发布时间: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 If FileSys.GetName(nn.Text).split(".")(0) = "xls" Then \'如果是xls文件
|
-- 作者:有点蓝 -- 发布时间:2019/10/21 17:11:00 -- For bb = 0 To ere \'在文件后插入分页符 If bb > 0 Then Dim pBreak = MSWord.WdBreakType.wdSectionBreakNextPage wapp1.ActiveWindow.Selection.InsertBreak(pBreak) End If If FileSys.GetName(nn.Text).split(".")(0) = "xls" Then \'如果是xls文件 End If …… finally wapp3.Quit |
-- 作者:天一生水 -- 发布时间:2019/10/21 19:08:00 -- 提示如下,请老师指教。 谢谢! 代码如下: 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 -- 还是一样的提示 |