Private Sub CommandButton1_Click()
'Dim Cmt As Comment
Dim excelApp As Object
Dim xlsWbk, objWdApp As Object
Dim commentsArray
Dim rows, temp, i, x, y As Integer
Dim filename As String
'Dim myWDoc As Word.Document
Dim authorName As String
'获取选择中文件的名字
filename = Application.GetOpenFilename
If filename = "False" Then
Exit Sub
End If
Set objWdApp = CreateObject("word.application")
objWdApp.Visible = False '隐式打开
Set mywdoc = objWdApp.Documents.Open(filename)
temp = 0
x = 12
y = 12
rows = mywdoc.Comments.Count
ReDim commentsArray(1 To rows, 1 To 4)
If rows = 0 Then
MsgBox "没有批注!"
End If
With Worksheets(1)
Do While .Cells(x, 1) <> ""
x = x + 1
Loop
If x > 12 Then
y = x
x = .Cells(x - 1, 1)
Else
x = 0
End If
End With
For i = 1 To rows
temp = temp + 1
x = x + 1
'序号
commentsArray(temp, 1) = x
'批注引用的内容
commentsArray(temp, 2) = mywdoc.Comments(i).Scope
'批注内容
commentsArray(temp, 3) = mywdoc.Comments(i).Range
'页/行
commentsArray(temp, 4) = "在第" & mywdoc.Comments(i).Scope.Information(3) & "页第" & mywdoc.Comments(i).Scope.Information(10) & "行"
'作者
authorName = mywdoc.Comments(i).Author
Next
Worksheets(1).Cells(2, 2) = mywdoc.Name
Worksheets(1).Cells(3, 2) = authorName
'mywdoc.BuiltinDocumentProperties (14) 获取总页数
With Worksheets(1)
.Range("A" & y).Resize(rows, 4) = commentsArray
.Columns.AutoFit
End With
mywdoc.Application.Quit
End Sub
Private Sub CommandButton2_Click()
Worksheets(1).Range("A12").Resize(200, 4) = ""
Worksheets(1).Cells(2, 2) = ""
Worksheets(1).Cells(3, 2) = ""
End Sub
界面