word检视意见导出(VBA)

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


界面

 

posted @ 2014-12-10 14:01  芊芊爸爸  阅读(522)  评论(0编辑  收藏  举报