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


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

主题：[求助]合并Word
帅哥哟，离线，有人找我吗？
有点蓝
 小大  1楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：112364 积分：572076 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：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
 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  2楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：112364 积分：572076 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：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
 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  3楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：112364 积分：572076 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：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
 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  4楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：112364 积分：572076 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：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
 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  5楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：112364 积分：572076 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/10/21 22:21: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 str() As String = {"12.docx","34.docx","123.xlsx"}
    Dim bb As Integer
    For Each s As String In str
        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 s.EndsWith(".doc") OrElse s.EndsWith(".docx") Then    '如果是doc文件
            Dim doc2 = wapp2.Documents.Open(ProjectPath & s)
            wapp2.ActiveWindow.Selection.WholeStory
            wapp2.ActiveWindow.Selection.copy
            wapp1.ActiveWindow.Selection.paste
        ElseIf s.EndsWith(".xls") OrElse s.EndsWith( ".xlsx") Then    '如果是xls文件
            Dim Wb As MSExcel.WorkBook = wapp3 .WorkBooks.Open(ProjectPath & s)
            Dim Ws As MSExcel.WorkSheet = Wb.WorkSheets(1) '指定要复制的工作表
            Ws.UsedRange.Copy
            wapp1.ActiveWindow.Selection.TypeParagraph
            wapp1.ActiveWindow.Selection.paste
        End If
    bb+= 1
    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
 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  6楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：112364 积分：572076 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/10/27 20:48:00 [显示全部帖子]

If dlg.ShowDialog = DialogResult.OK Then
    Dim tr As WinForm.TreeView
    Dim nd As WinForm.TreeNode
    tr = e.Form.Controls("TreeView1")
    If tr.nodes.count = 0 Then    ’如果添加过文件
     nd = Tr.Nodes.Add("文件目录：")
    Else
     nd = Tr.Nodes(0)
    End If
        For Each fl As String In dlg.FileNames     ’如果是第一次添加
            nd.Nodes.Add(fl)        '文件路径添加至子节点
            count += 1
        Next
End If
 回到顶部
RSS2.0 | Xhtml无图版 | Xslt无图版 Copyright © 2000 - 2018 foxtable.com Tel: 4000-810-820 粤ICP备11091905号
   Powered By Dvbbs Version 8.3.0
页面执行时间 0.05859 秒, 5 次数据查询