Truy xuất comments trong word sang word

[KhoiSMC]

Tiếp theo hướng dẫn topic trước là xuất comments trong word sang excel,

Nay mình mở thêm topic này là xuất comments của file word đang thực hiện sang file word mới, có mô tả như sau:
1. Lấy tên file word đang thực hiện sang file word mới.
2. Xuất toàn bộ các heading của file word đang thực hiện sang file word mới (như là tạo mục lục tự động của word ý)
3. Trong file word đang thực hiện nếu trong mỗi phần heading mà có comments thì xuất sang file word mới (mình đã tạo được code này, nhưng số trang mà comments xuất hiện thì chưa làm được)

Xin các bạn download file thực hiện: "Schedule visit 10 to 18 March 2014 lgk - to word.doc"
và file kết quả mong muốn: "ket qua.docx"

Mong các bạn giúp đỡ
Thanks
Khoi

 

[siwtom]

Tiếp theo hướng dẫn topic trước là xuất comments trong word sang excel,

Nay mình mở thêm topic này là xuất comments của file word đang thực hiện sang file word mới, có mô tả như sau:
1. Lấy tên file word đang thực hiện sang file word mới.
2. Xuất toàn bộ các heading của file word đang thực hiện sang file word mới (như là tạo mục lục tự động của word ý)
3. Trong file word đang thực hiện nếu trong mỗi phần heading mà có comments thì xuất sang file word mới (mình đã tạo được code này, nhưng số trang mà comments xuất hiện thì chưa làm được)

Xin các bạn download file thực hiện: "Schedule visit 10 to 18 March 2014 lgk - to word.doc"
và file kết quả mong muốn: "ket qua.docx"

Mong các bạn giúp đỡ
Thanks
Khoi

0. Mở tập tin Schedule visit 10 to 18 March 2014 lgk - to word.doc

1. Alt + F11 để vào VBE --> Insert --> Module

2. Dán code sau vào Module1

Public Type COMMENTDATA
    Initial As String
    index As Long
    Page As Long
    Date_ As Date
    Content As String
    Heading As String
    Scope As String
'    HeadingText As String
'    HeadingStyle As String
    PreviousHeadings As String
End Type

Function GetComments(doc As Object, result As Boolean) As COMMENTDATA()
Dim index As Long
Dim Scope As Object
Dim comment() As COMMENTDATA
Dim PreviousHeadings As String
Dim currPage As Long
    result = doc.Comments.Count > 0
    If Not result Then Exit Function
    ReDim comment(1 To doc.Comments.Count)
    For index = 1 To doc.Comments.Count
        With comment(index)
            Set Scope = doc.Comments(index).Scope
            .Scope = Scope.text
            .Page = doc.Comments(index).Reference.Information(wdActiveEndAdjustedPageNumber)
            GetHeading Scope.Paragraphs(1), comment(index)
            If currPage <> .Page Then PreviousHeadings = ""
            currPage = .Page
            .PreviousHeadings = PreviousHeadings
            If PreviousHeadings = "" Then
                PreviousHeadings = .Heading
            Else
                PreviousHeadings = PreviousHeadings & vbCrLf & .Heading
            End If
            .index = doc.Comments(index).index
            .Content = doc.Comments(index).Range.text
            .Initial = doc.Comments(index).Initial
            .Date_ = Format(doc.Comments(index).Date, "dd/MM/yyyy")
        End With
    Next
    GetComments = comment
End Function

Sub GetHeading(Para As Object, cd As COMMENTDATA)
Dim ParaAbove As Object, text As String
    If Left(Para.Range.ParagraphStyle, 4) = "Head" Then
        GoTo end_
    End If
    Set ParaAbove = Para
    
    Do While ParaAbove.OutlineLevel = Para.OutlineLevel
        If ParaAbove.Previous Is Nothing Then
            Exit Do
        Else
            Set ParaAbove = ParaAbove.Previous
        End If
    Loop
end_:
    text = ParaAbove.Range.text
'    cd.HeadingText = ParaAbove.Range.ListFormat.ListString & " " & Left(text, Len(text) - 1)
'    cd.HeadingStyle = ParaAbove.Range.ParagraphStyle
    cd.Heading = "[" & ParaAbove.Range.ParagraphStyle & "]" & ParaAbove.Range.ListFormat.ListString & " " & Left(text, Len(text) - 1)
End Sub

Sub test()
Dim index As Long, s As String, result As Boolean
Dim comment() As COMMENTDATA, doc As Object
    comment = GetComments(ThisDocument, result)
    If result Then
        s = ThisDocument.FullName
        s = Mid(s, InStrRev(s, "\") + 1)
        For index = 1 To UBound(comment)
            With comment(index)
                s = s & vbCrLf & _
                    .PreviousHeadings & vbCrLf & _
                    .Heading & vbCrLf & _
                    "Ghi ch" & ChrW(250) & " s" & ChrW(7889) & ": " & .Initial & .index & "; " & _
                    "N" & ChrW(7897) & "i dung: " & .Scope & " T" & ChrW(7841) & "i trang: " & .Page & vbCrLf & _
                    .Content
            End With
        Next
        Set doc = Documents.Add
        doc.Range.text = s
    End If
End Sub

3. Chạy Sub Test

4. Sub Test để làm đúng cái bạn cần. Nhưng trong tương lai bạn có thể có nhu cầu khác. Lúc đó thì chạy

comment = GetComments([B][COLOR=#ff0000]ThisDocument[/COLOR][/B], result)

Chỗ đỏ đỏ thay bàng cái mà bạn muốn.

comment là mảng mà mỗi phần tử là cấu trúc COMMENTDATA (cấu trúc được định nghĩa bởi người dùng). Bạn có nhu cầu lấy gì trong cấu trúc đó là tùy bạn

 

[KhoiSMC]

Cam on ban nhe, mình sẽ thử coi

Thanks bạn nhiều
khoi

 

[KhoiSMC]

Cám ơn bạn, mình đã thử xong rồi, chạy tương đối ổn định theo như mong muốn của mình. Cám ơn bạn nhiều nhé.
Mình và nmhung49 cũng đang nghiên cứu vụ tương tự như chủ đề này. Nếu siwtom có cao kiến gì thì xin giúp đỡ nhé.
tại: http://www.giaiphapexcel.com/forum/showthread.php?90256-Truy-xuất-comments-trong-Word-sang-Excel

Thanks
Khoi

 

[siwtom]

Cám ơn bạn, mình đã thử xong rồi, chạy tương đối ổn định theo như mong muốn của mình. Cám ơn bạn nhiều nhé.

Tương đối ổn định? Tức có lúc chạy sai? Nếu thế thì xin chỉ ra sai ở đâu. Nếu là tập tin khác thì đính kèm để tôi có thể kiểm nghiệm.

 

[KhoiSMC]

Tương đối ổn định? Tức có lúc chạy sai? Nếu thế thì xin chỉ ra sai ở đâu. Nếu là tập tin khác thì đính kèm để tôi có thể kiểm nghiệm.

Chào siwtom,

Hi mình cũng đã thử với file đính kèm, tuy nhiên có một số lỗi (error 91) nhờ bạn chỉnh sửa file đính kèm với nhé.
Nhờ bạn download tại file tại dropbox: https://www.dropbox.com/s/mvbtn9mi2ky805f/Do an.doc

Thanks
Khoi

 

[siwtom]

Chào siwtom,

Hi mình cũng đã thử với file đính kèm, tuy nhiên có một số lỗi (error 91) nhờ bạn chỉnh sửa file đính kèm với nhé.
Nhờ bạn download tại file tại dropbox: https://www.dropbox.com/s/mvbtn9mi2ky805f/Do an.doc

Thanks
Khoi

Trong Sub GetHeading hiện thời bạn có

    If Left(Para.Range.ParagraphStyle, 4) = "Head" Then
        GoTo end_
    End If

    Set ParaAbove = Para

Bạn đổi lại thành

    Set ParaAbove = Para

    If Left(Para.Range.ParagraphStyle, 4) = "Head" Then
        GoTo end_
    End If

Có trục trặc thì phải nói chứ bạn? Ai cũng có lúc sơ xuất. Im lặng thì ai biết được

 

[KhoiSMC]

thanks bạn, mình đã thay thế đoạn code bạn gửi cho rồi, chạy đúng theo ý định thiết kế của mình.
Cám ơn bạn nhiều nhé.

Khoi
@: nhờ bạn giúp đỡ vấn đề này nhé: http://www.giaiphapexcel.com/forum/showthread.php?90256-Truy-xuất-comments-trong-Word-sang-Excel

 

[siwtom]

thanks bạn, mình đã thay thế đoạn code bạn gửi cho rồi, chạy đúng theo ý định thiết kế của mình.
Cám ơn bạn nhiều nhé.

Khoi
@: nhờ bạn giúp đỡ vấn đề này nhé: http://www.giaiphapexcel.com/forum/showthread.php?90256-Truy-xuất-comments-trong-Word-sang-Excel

Tôi đã viết bên kia

 

[KhoiSMC]

Tôi đã viết bên kia

Thanks bạn nhiều, mình đã áp dụng thành công. bộ MS của BillGate thật tuyệt vời cùng với những con nguời trên GPE thì công việc giải quyết thật hiệu quả.

Thanks
Khoi