VBA读取word文档表格中table的cell的text文本
已有 11546 次阅读
2010-6-4 16:40
|个人分类:学习篇|系统分类:科研笔记
Sub Readtable()
Dim filename As String
Dim filenum As Long
Dim fileslist As String
Dim outfile As String
Dim outfile_log As String
outfile = "I:综合整理结果20100525-2其它各省1257省集合_125.txt"
fileslist = "I:综合整理结果20100525-2其它各省125Filellist_125.txt" '输入读取的word文件列表
outfile_log = "I:综合整理结果20100525-2其它各省1257省集合_125_log.txt"
filenum = 125 '输入读取的word文件列表中的文件数
Open fileslist For Input As #1
Open outfile For Output As #2
Open outfile_log For Output As #3
Dim wdApp As Word.Application, wdDoc As Word.Document
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0
Dim tableNum As Long
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim r1 As Long, r7 As Long, r4 As Long
Dim result As String
Dim temp As String, temp00 As String, temp0 As String, temp1 As String, temp2 As String
Dim oCel As Cell
Dim flag As Long
For i = 1 To filenum
Line Input #1, filename
Set wdDoc = wdApp.Documents.Open(filename)
wdApp.Visible = True
'WrdApp.Documents.Open filename:=myFilename
'wdDoc.PrintOut
'wdDoc.SaveAs "C:temphello.doc"
wdDoc.Activate
tableNum = ActiveDocument.Tables.Count
Print #3, filename, "#", tableNum
result = ""
Set oCel = Nothing
For j = 1 To tableNum
'Set oTable = ActiveDocument.Tables(j)
'Dim oCel0 As Cell
'Dim oCel1 As Cell
'Dim oCel2 As Cell
'Obtain location cells
Set oCel = ActiveDocument.Tables(j).Cell(2, 2)
temp = Mid(oCel.Range.Text, 1, 1)
'当cell(2,2)为“地”时
r7 = 7
r4 = 4
r1 = 2
flag = 0
'当cell(2,2)为"调"时
If temp = "调" Then
r7 = r7 - 1
r4 = r4 - 1
r1 = r1 - 1
flag = -1
End If
If temp = "因" Then
r7 = r7 + 1
r4 = r4 + 1
r1 = r1 + 1
flag = 1
End If
'读取记录表类型
temp00 = ""
Set oCel = ActiveDocument.Tables(j).Cell(r7, 2)
'oCel.Range.MoveEnd Unit:=wdCharacter, Count:=-1
temp00 = Replace(oCel.Range.Text, Chr(13), ",") + "#"
'**************************************************************
'读取地点,调查时间
temp0 = ""
For k = r1 To 1 + r1
Set oCel = ActiveDocument.Tables(j).Cell(k, 3)
'oCel.Range.MoveEnd Unit:=wdCharacter, Count:=-1
temp0 = temp0 + "#" + Replace(oCel.Range.Text, Chr(13), ",")
Next k
'3 地理坐标 X:0628489 Y:4190334
temp1 = ""
For m = 1 To 4
Set oCel = ActiveDocument.Tables(j).Cell(r4, m)
'oCel.Range.MoveEnd Unit:=wdCharacter, Count:=-1
temp1 = temp1 + "#" + Replace(oCel.Range.Text, Chr(13), ",")
Next m
'Set oCel0 = ActiveDocument.Tables(j).Cell(4, 1)
'Set oCel1 = ActiveDocument.Tables(j).Cell(4, 3)
'Set oCel2 = ActiveDocument.Tables(j).Cell(4, 4)
'Obtain 轨道号
'成像时间,沙化类型 , 沙化程度, 土地利用类型, 主要植物种, 主要植被盖度, 植被总盖度,
'植被长势, 土壤类型, 土壤质地, 治理措施, 影像色彩, 影像纹理, 分布状况, 比例尺
temp2 = ""
For n = 5 + flag To 10 + flag
Set oCel = ActiveDocument.Tables(j).Cell(n, 3)
'oCel.Range.MoveEnd Unit:=wdCharacter, Count:=-1
temp2 = temp2 + "#" + Replace(oCel.Range.Text, Chr(13), ",")
Next n
'Set oCel4 = ActiveDocument.Tables(j).Cell(6, 3)
'Set oCel5 = ActiveDocument.Tables(j).Cell(5, 3)
'For Each aCell In oTable.Rows(4).Cells(1 - 4) '设定读取的表行
'Set myRange = ActiveDocument.Range(Start:=aCell.Range.Start, End:=aCell.Range.End - 1)
'MsgBox myRange.Text
'Set myRange = aCell.Range
'myRange.MoveEnd Unit:=wdCharacter, Count:=-1 ' 非常重要,目的是去掉换行符' 否则内容后面会有个小圆点
'MsgBox myRange.Text
'‘temp = Concat(",", myRange.Text)
result = temp00 + temp0 + temp1 + temp2
'Next aCell
Print #2, CStr(i), "*", CStr(j), "*", result
Next j
wdDoc.Close
Next i
Close #1
Close #2
Close #3
End Sub
转载本文请联系原作者获取授权,同时请注明本文来自付安民科学网博客。
链接地址:http://blog.sciencenet.cn/blog-219445-332048.html
上一篇:VBA 向ArcGIS的mdb数据库中添加照片
下一篇:EXCEL中的VBA操作