Foxtable(狐表) → 用户栏目 → 专家坐堂 → [求助]输出word表格


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

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


加好友 发短信
等级：超级版主 帖子：113473 积分：577848 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/11/7 15:49:00 [显示全部帖子]

'//////////////////生成表格的代码
Dim app As New MSWord.Application
try
    Dim doc = app.Documents.Open(ProjectPath & "\Reports\病害整理.doc")
    
    '////////////////生成临时表
    Dim tbl As Table = Tables("病害统计表") '定义一个表
    Dim Regions As List(Of String) = tbl.DataTable.GetValues("桥梁名称")  '从指定列中,获取不重复的值,以字符集合的形式返回|桥梁代码|部件名称
    Dim  WdLine = MSWord.WdUnits.wdLine
    Dim tcount = 2
    Dim Js As Integer = 1 '第一次循环赋值
    Dim dr As DataRow
    For Each Region As String In Regions
        Dim drs As List(of DataRow) = tbl.DataTable.Select("[桥梁名称] = '" & Region & "'","部件名称")
        For i As Integer = 0 To drs.Count - 1 Step 3
            
            '////写入wordtest1
            app.Selection.TypeText (Text:= Region)
            doc.Tables.Add(Range:=app.Selection.Range,NumRows:=1, NumColumns:= 5) '返回一个 Table 对象,该对象代表添加至文档中的空白新表格
            '///定义表格格式
            With app.Selection.Tables(1)
                .ApplyStyleHeadingRows = True
                .ApplyStyleLastRow = True
                .ApplyStyleFirstColumn = True
                .ApplyStyleLastColumn = True
                .Style = "网格型"
                '.Cell(1,1).SetWidth (ColumnWidth:=36,RulerStyle:= wdAdjustNone)
            End With
            Dim cls() As String = {"部件名称","构件编号","评定项目","缺损情况病害描述","照片或图片"}
            For Each name As String In cls
                app.Selection.TypeText(Text:=Name)
                app.Selection.MoveRight(Unit:=12)
            Next
            For j As Integer = i To math.Min(i+2,drs.Count - 1)
                dr = drs(j)
                For Each name As String In cls
                    app.Selection.TypeText(Text:=dr(Name))
                    If j = math.Min(i+2,drs.Count - 1) AndAlso name = "照片或图片"
                    Else
                        app.Selection.MoveRight(Unit:=12)
                    End If
                Next
            Next
            app.Selection.MoveDown(WdLine , tcount , Nothing)
            'app.Selection.TypeParagraph()
        Next
    Next
    'app.Visible = True
catch ex As exception
    msgbox(ex.message)
    app.Quit
finally
End try
 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  2楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：113473 积分：577848 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/11/7 16:36:00 [显示全部帖子]

我测试没有问题

 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  3楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：113473 积分：577848 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/11/8 13:44:00 [显示全部帖子]

上传实例

 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  4楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：113473 积分：577848 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/11/8 13:55:00 [显示全部帖子]

试试
……
        For Each dr As DataRow In drs
            app.Selection.TypeText (Text:= Region) '写桥明
            doc.Tables.Add(Range:=app.Selection.Range,NumRows:=1, NumColumns:= 5) '返回一个 Table 对象,该对象代表添加至文档中的空白新表格
            '///定义表格格式
            With app.Selection.Tables(1)
                .ApplyStyleHeadingRows = True
                .ApplyStyleLastRow = True
                .ApplyStyleFirstColumn = True
                .ApplyStyleLastColumn = True
                .Style = "网格型"
                '.Cell(1,1).SetWidth (ColumnWidth:=36,RulerStyle:= wdAdjustNone)
            End With
            Dim cls() As String = {"部件名称","构件编号","细部位置","缺损情况病害描述","照片或图片"}
            For Each Name As String In cls '写表头
                app.Selection.TypeText(Text:=Name)
                app.Selection.MoveRight(Unit:=12)
            Next
            For j As Integer = 0 To drs.Count - 1
                dr = drs(j)
                For Each name As String In cls
                    If name = "照片或图片"then
                        Dim lst As List(of String) = dr.lines("照片或图片")
                        For Each s As String In lst
                            Dim img = ProjectPath & "Attachments\" & s '图片路径
                            Dim rg = app.Selection.InlineShapes.AddPicture( img ,False,True) '插入照片
                            rg.Width = 217.6 '图片宽(7.7cm)
                            rg.Height=217.6  '图片高
                        Next
                        
                    Else
                        app.Selection.TypeText(Text:=dr(name)) '插入指定的文本
                    End If
                    If j = drs.Count - 1 AndAlso name = "照片或图片"
                    Else
                        app.Selection.MoveRight(Unit:=12)
                    End If
                Next
            Next
            app.Selection.MoveDown(WdLine , tcount , Nothing)
            
            app.Selection.TypeParagraph()
            '/////添加照片
        Next
……
 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  5楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：113473 积分：577848 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/11/8 16:23:00 [显示全部帖子]

试试
For Each dr As DataRow In drs
            app.Selection.TypeText (Text:= Region) '写桥明
            doc.Tables.Add(Range:=app.Selection.Range,NumRows:=1, NumColumns:= 5) '返回一个 Table 对象,该对象代表添加至文档中的空白新表格
            '///定义表格格式
            With app.Selection.Tables(1)
                .ApplyStyleHeadingRows = True
                .ApplyStyleLastRow = True
                .ApplyStyleFirstColumn = True
                .ApplyStyleLastColumn = True
                .Style = "网格型"
                '.Cell(1,1).SetWidth (ColumnWidth:=36,RulerStyle:= wdAdjustNone)
            End With
            Dim cls() As String = {"部件名称","构件编号","细部位置","缺损情况病害描述","照片或图片"}
            For Each Name As String In cls '写表头
                app.Selection.TypeText(Text:=Name)
                app.Selection.MoveRight(Unit:=12)
            Next
            For j As Integer = 0 To drs.Count - 1
                dr = drs(j)
                For Each name As String In cls
                    app.Selection.TypeText(Text:=dr(name)) '插入指定的文本
                    If j = drs.Count - 1 AndAlso name = "照片或图片"
                    Else
                        app.Selection.MoveRight(Unit:=12)
                    End If
                Next
            Next
            app.Selection.MoveDown(WdLine , tcount , Nothing)

            app.Selection.TypeParagraph()

        Next
            '///////添加照片
            For r As Integer = 0 To drs.Count -1
                Dim lst As List(of String) = drs(r).lines("照片或图片")
                For Each s As String In lst
                    Dim img = ProjectPath & "Attachments\" & s '图片路径
                    Dim rg = app.Selection.InlineShapes.AddPicture( img ,False,True) '插入照片
                    rg.Width = 217.6 '图片宽(7.7cm)
                    rg.Height=217.6  '图片高
                Next
            Next
            app.Selection.MoveDown(WdLine , tcount , Nothing)

            app.Selection.TypeParagraph()
 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  6楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：113473 积分：577848 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/11/8 16:50:00 [显示全部帖子]

上传可以测试出问题的完整实例，包含数据、图片

 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  7楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：113473 积分：577848 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/11/9 14:34:00 [显示全部帖子]

'//////////////////生成表格的代码
Dim app As New MSWord.Application
try
    Dim doc = app.Documents.Open(ProjectPath & "\Reports\病害整理.doc")
    Dim tbl As Table = Tables("病害统计表") '定义一个表
    Dim Regions As List(Of String) = tbl.DataTable.GetValues("桥梁名称")  '从指定列中,获取不重复的值,以字符集合的形式返回|桥梁代码|部件名称
    Dim WdLine = MSWord.WdUnits.wdLine
    Dim tcount = 2
    Dim pgb As WinForm.ProgressBar = e.Form.Controls("ProgressBar1")
    
    
    Dim Label1 As WinForm.Label = e.Form.Controls("Label1")
    For Each Region As String In Regions
        Label1.Text = "正在处理 : " & Region
        pgb.Value = 2
        
        Dim drs As List(of DataRow) = tbl.DataTable.Select("[桥梁名称] = '" & Region & "'","Bjpx,构件编号")
        pgb.Maximum = drs.Count
        Application.Doevents
        'For Each dr As DataRow In drs
        Dim dr As DataRow
        app.Selection.TypeText (Text:= Region) '写桥明
        doc.Tables.Add(Range:=app.Selection.Range,NumRows:=1, NumColumns:= 5) '返回一个 Table 对象,该对象代表添加至文档中的空白新表格
        '///定义表格格式
        With app.Selection.Tables(1)
            .ApplyStyleHeadingRows = True
            .ApplyStyleLastRow = True
            .ApplyStyleFirstColumn = True
            .ApplyStyleLastColumn = True
            .Style = "网格型"
            '.Cell(1,1).SetWidth (ColumnWidth:=36,RulerStyle:= wdAdjustNone)
        End With
        Dim cls() As String = {"部件名称","构件编号","细部位置","缺损情况病害描述","照片或图片"}
        For Each Name As String In cls '写表头
            app.Selection.TypeText(Text:=Name)
            app.Selection.MoveRight(Unit:=12)
        Next
        For j As Integer = 0 To drs.Count - 1
            dr = drs(j)
            pgb.Value = j
            Application.Doevents
            For Each name As String In cls
                app.Selection.TypeText(Text:=dr(name)) '插入指定的文本
                If j = drs.Count - 1 AndAlso name = "照片或图片"
                Else
                    app.Selection.MoveRight(Unit:=12)
                End If
            Next
        Next
        app.Selection.MoveDown(WdLine , tcount , Nothing)
        app.Selection.TypeParagraph()
        'Exit For
        'Next
        '///////添加照片
        For r As Integer = 0 To drs.Count -1
            Dim lst As List(of String) = drs(r).lines("照片或图片")
            For Each s As String In lst
                Dim img = ProjectPath & "Attachments\" & s '图片路径
                Dim rg = app.Selection.InlineShapes.AddPicture( img ,False,True) '插入照片
                rg.Width = 217.6 '图片宽(7.7cm)
                rg.Height = 162.776  '图片高
            Next
            app.Selection.MoveDown(WdLine , tcount , Nothing)
            app.Selection.TypeParagraph()
            
        Next
    Next
    Label1.Text = "正在保存....."
    Application.Doevents
    doc.saveas(ProjectPath & "\Reports\病害整理1.docx",MSWord.WdSaveFormat.wdFormatDocumentDefault)
    doc.Close()
    app.Quit
    'app.Visible = True
    MessageBox.Show("输出完成")
catch ex As exception
    msgbox(ex.message)
    app.Quit
finally
End try
 回到顶部
帅哥哟，离线，有人找我吗？
有点蓝
 小大  8楼 | 信息 | 搜索 | 邮箱 | 主页 | UC


加好友 发短信
等级：超级版主 帖子：113473 积分：577848 威望：0 精华：9 注册：2015/6/24 9:21:00 		  发帖心情 Post By：2019/11/9 17:03:00 [显示全部帖子]

把图片压缩一下，5M一个图片。复制的方法可能复制到不是原图。而使用代码添加的都是原图

 回到顶部
RSS2.0 | Xhtml无图版 | Xslt无图版 Copyright © 2000 - 2018 foxtable.com Tel: 4000-810-820 粤ICP备11091905号
   Powered By Dvbbs Version 8.3.0
页面执行时间 0.06641 秒, 5 次数据查询