- 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=169415)
-- 发布时间：2021/6/15 21:15:00
-- [求助]将多个统计表写入Word
蓝老师好！
请指教代码：
1、每月有8个固定报表（由8个按钮控制生成），见图1。要写入一个“明传”的Word文档中。
2、比如第一个固定报表在Word文档中的最终效果，见图2。它的标题行与foxtable中生成的统计表有些不同。
3、我用下面的代码试着写入了两个表，有几个地方达不到效果，比如标题行、百分比的两位小数等。
我这样考虑，因为是固定报表，能不能把带标题行的空表先放入Word文档，然后模拟点击按钮，逐个将生成的统计表内容（不包括标题）写入Word中预先准备好的的空表中？
谢谢！
代码：
Dim tm As String = ProjectPath & "Attachments\\中院明传.doc" \'指定模板文件
Dim fl As String = ProjectPath & "Reports\\" & Format(Date.now,"yyyyMMddHHmmss") & "中院明传.doc" \'指定目标文件
FileSys.CopyFile(tm, fl,True)
\'Dim ps As System.Diagnostics.Process() = System.Diagnostics.Process.GetProcessesByName("WinWord")
\'For Each p As System.Diagnostics.Process In ps
\'p.kill ’杀进程
\'Next
Dim app As New MSWord.Application
try
Dim doc = app.Documents.Open(fl)
e.Form.Controls("But01").PerformClick() ’模拟点击按钮，生成统计表1
If app.ActiveWindow.Selection.Find.Execute("表1") Then
\'插入表格,方法1或2
Dim dt As DataTable = Tables("质效分析_Table1").DataTable
doc.Tables.Add(Range:=app.Selection.Range,NumRows:=1, NumColumns:= dt.DataCols.Count)
With app.Selection.Tables(1)
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
.Style = "网格型"
End With
For Each dc As DataCol In dt.DataCols
app.Selection.TypeText(Text:=dc.Name)
app.Selection.MoveRight(Unit:=12)
Next
For Each dr As DataRow In dt.DataRows
For Each dc As DataCol In dt.DataCols
app.Selection.TypeText(Text:=dr(dc.Name))
app.Selection.MoveRight(Unit:=12)
Next
Next
End If
\'Application.DoEvents
e.Form.Controls("But02").PerformClick()
If app.ActiveWindow.Selection.Find.Execute("表2") Then
\'插入表格,方法1或2
Dim dt As DataTable = Tables("质效分析_Table1").DataTable
doc.Tables.Add(Range:=app.Selection.Range,NumRows:=1, NumColumns:= dt.DataCols.Count)
With app.Selection.Tables(1)
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
.Style = "网格型"
End With
For Each dc As DataCol In dt.DataCols
app.Selection.TypeText(Text:=dc.Name)
app.Selection.MoveRight(Unit:=12)
Next
For Each dr As DataRow In dt.DataRows
For Each dc As DataCol In dt.DataCols
app.Selection.TypeText(Text:=dr(dc.Name))
app.Selection.MoveRight(Unit:=12)
Next
Next
End If
\'Application.DoEvents
app.Visible = True
catch ex As exception
msgbox(ex.message)
app.Quit
finally
End try
此主题相关图片如下：截屏图片 (2).jpg
[此贴子已经被作者于2021/6/16 11:06:10编辑过]
-- 发布时间：2021/6/15 23:01:00
--
参考：https://docs.microsoft.com/zh-cn/office/vba/api/word.table
给指定单元格赋值：https://docs.microsoft.com/zh-cn/office/vba/api/word.table.cell
-- 发布时间：2021/6/16 11:04:00
--
谢谢蓝老师！
我弹出值没问题，赋值时报错，请老师帮忙看看：
Dim app As New MSWord.Application
try
Dim fileName = "D:\\test.doc"
Dim doc = app.Documents.Open(fileName)
Dim t = doc.Tables(2) \'word文档中的第二个表
For Each r As Row In Tables("表B").Rows \'遍历数据表的行
For Each c As Col In Tables("表B").Cols \'遍历数据表的列
\'msgbox(r.Index+1 & "=" & c.Index+1 & "=" & r(c.name))
t.Cell(r.Index+1,c.Index+1) = r(c.name) \'赋值
Next
Next
catch ex As exception
msgbox(ex.message)
finally
app.Quit
End try
此主题相关图片如下：截屏图片.jpg
-- 发布时间：2021/6/16 11:11:00
--
For Each c As Col In Tables("表B").Cols \'遍历数据表的列
msgbox(t.Cell(r.Index+1,c.Index+1).Range.text)
t.Cell(r.Index+1,c.Index+1).Range.text = r(c.name) \'赋值
Next