- 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=142822)
-- 发布时间：2019/11/7 10:14:00
-- [求助]输出word表格
| 下载信息 [文件大小： 下载次数： ] | |
 点击浏览该文件:测试.rar |
数据表输出到word文件中，求哪位大神抽空看看
/////////////下图是想要实现的结果
此主题相关图片如下：qq截图20191107100148.png
此主题相关图片如下：病害整理.jpg
此主题相关图片如下：qq截图20191107100148.png////////////下图目前实际输出的结果
此主题相关图片如下：病害整理.jpg[此贴子已经被作者于2019/11/7 15:34:35编辑过]
-- 发布时间：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
-- 发布时间：2019/11/7 16:32:00
--
感谢大神的帮助，代码粘贴进去后，点击按钮没反应，麻烦再抽空看看
-- 发布时间：2019/11/7 16:36:00
--
我测试没有问题
-- 发布时间：2019/11/7 17:51:00
--
非常感谢，我再看看
-- 发布时间：2019/11/8 12:19:00
--
根据修改的代码我重新调了下，但是会出现如下图的错误（红框标注的地方，大部分合适，有个别地方就会出现问题），麻烦帮忙看看
此主题相关图片如下：qq截图20191108121424.png
此主题相关图片如下：qq截图20191108121302.png
\'//////////////////生成表格的代码
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
For Each Region As String In Regions
Dim drs As List(of DataRow) = tbl.DataTable.Select("[桥梁名称] = \'" & Region & "\'","Bjpx,构件编号")
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)
\'///////添加照片
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.TypeParagraph()
\'/////添加照片
Exit For
Next
Next
\'app.Visible = True
MessageBox.Show("输出完成")
catch ex As exception
msgbox(ex.message)
app.Quit
finally
End try
-- 发布时间：2019/11/8 13:44:00
--
上传实例
-- 发布时间：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
……
-- 发布时间：2019/11/8 15:46:00
--
问题1：前面混乱的问题好了，但是没法保存。
问题2：一个桥名的表格完了之后，照片全按顺序显示到表格的下面就可以，直接显示到表格，表格行太高了
问题3：有没有办法加个显示进度的，一直等不知道啥时候能输出完
此主题相关图片如下：qq截图20191108153526.png
-- 发布时间：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()