Экспорт комментариев Powerpoint в Excel - PullRequest
Новая
       18

Экспорт комментариев Powerpoint в Excel

1 голос
/ 10 апреля 2019

Я пытаюсь создать макрос для экспорта комментариев Powerpoint в Excel со столбцами для разных заголовков, таких как автор, номер слайда и т. Д.

Попробовал использовать код, который у меня есть для Word для этого макроса, который работаетхорошо, но, будучи новичком в VBA, я не знаю, как настроить этот код для Powerpoint 

Sub ExportWordComments()

' Purpose: Search for comments in any text that's been pasted into
' this document, then export them into a new Excel spreadsheet.
' Requires reference to Microsoft Excel 15.0 Object Library in VBA,
' which should already be saved with as part of the structure of
' this .docm file.

Dim bResponse As Integer

' Exit routine if no comments have been found.
If ActiveDocument.Comments.Count = 0 Then
  MsgBox ("No comments found in this document")
  Exit Sub
Else
  bResponse = MsgBox("Do you want to export all comments to an Excel worksheet?", _
              vbYesNo, "Confirm Comment Export")
  If bResponse = 7 Then Exit Sub
End If

' Create a object to hold the contents of the
' current document and its text. (Shorthand
' for the ActiveDocument object.
Dim wDoc As Document
Set wDoc = ActiveDocument

' Create objects to help open Excel and create
' a new workbook behind the scenes.
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook

Dim i As Integer
Dim oComment As Comment         'Comment object

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False

' Create a new Workbook. Shouldn't interfere with
' other Workbooks that are already open. Will have
' at least one worksheet by default.
Set xlWB = xlApp.Workbooks.Add

With xlWB.Worksheets(1).Range("A1")

  ' Create headers for the comment information
  .Offset(0, 0) = "Comment Number"
  .Offset(0, 1) = "Page Number"
  .Offset(0, 2) = "Reviewer Initials"
  .Offset(0, 3) = "Reviewer Name"
  .Offset(0, 4) = "Date Written"
  .Offset(0, 5) = "Comment Text"
  .Offset(0, 6) = "Section"

  ' Export the actual comments information
  For i = 1 To wDoc.Comments.Count
   Set oComment = wDoc.Comments(i)
   Set rngComment = oComment.Reference
   rngComment.Select
   Set rngHeading = wDoc.Bookmarks("\HeadingLevel").Range
   rngHeading.Collapse wdCollapseStart
   Set rngHeading = rngHeading.Paragraphs(1).Range
  .Offset(i, 0) = oComment.Index
  .Offset(i, 1) = oComment.Reference.Information(wdActiveEndAdjustedPageNumber)
  .Offset(i, 2) = oComment.Initial
  .Offset(i, 3) = oComment.Author
  .Offset(i, 4) = Format(oComment.Date, "mm/dd/yyyy")
  .Offset(i, 5) = oComment.Range
  .Offset(i, 6) = rngHeading.ListFormat.ListString & " " & rngHeading.Text
Next i

End With

' Make the Excel workbook visible
xlApp.Visible = True

' Clean up our objects
Set oComment = Nothing
Set xlWB = Nothing
Set xlApp = Nothing
End Sub

На выходе получается новая книга Excel с листом и 7 столбцами, которые показывают номер комментария, номер страницы, Инициалы рецензента, имя рецензента, дата написания, текст комментария и раздел (заголовок)

1 Ответ

3 голосов
/ 10 апреля 2019

Вот пример, который вы можете адаптировать с помощью кода выше. Он просматривает все слайды и отслеживает все комментарии на каждом слайде. 

Option Explicit

Sub ExportPowerpointComments()
    Dim slideNumber As Long
    Dim commentNumber As Long

    Dim thisSlide As Slide
    For Each thisSlide In ActivePresentation.Slides
        slideNumber = thisSlide.slideNumber
        Dim thisComment As Comment
        For Each thisComment In thisSlide.Comments
            commentNumber = commentNumber + 1
            With thisComment
                Debug.Print commentNumber & vbTab;
                Debug.Print slideNumber & vbTab;
                Debug.Print .AuthorInitials & vbTab;
                Debug.Print .Author & vbTab;
                Debug.Print Format(.DateTime, "dd-mmm-yyyy hh:mm") & vbTab;
                Debug.Print .Text & vbTab
            End With
        Next thisComment
    Next thisSlide
End Sub

РЕДАКТИРОВАТЬ: обновленный код для отображения сохранения данных комментария в Excel 

Option Explicit

Sub ExportPointpointComments()
    ' Create objects to help open Excel and create
    ' a new workbook behind the scenes.
    Dim xlApp As Excel.Application
    Dim xlWB As Excel.Workbook

    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False

    ' Create a new Workbook. Shouldn't interfere with
    ' other Workbooks that are already open. Will have
    ' at least one worksheet by default.
    Set xlWB = xlApp.Workbooks.Add

    With xlWB.Worksheets(1).Range("A1")
        ' Create headers for the comment information
        .Offset(0, 0) = "Comment Number"
        .Offset(0, 1) = "Slide Number"
        .Offset(0, 2) = "Reviewer Initials"
        .Offset(0, 3) = "Reviewer Name"
        .Offset(0, 4) = "Date Written"
        .Offset(0, 5) = "Comment Text"
        .Offset(0, 6) = "Section"

        Dim slideNumber As Long
        Dim commentNumber As Long
        Dim thisSlide As Slide
        For Each thisSlide In ActivePresentation.Slides
            slideNumber = thisSlide.slideNumber
            Dim thisComment As Comment
            For Each thisComment In thisSlide.Comments
                commentNumber = commentNumber + 1
                .Offset(commentNumber, 0) = commentNumber
                .Offset(commentNumber, 1) = slideNumber
                .Offset(commentNumber, 2) = thisComment.AuthorInitials
                .Offset(commentNumber, 3) = thisComment.Author
                .Offset(commentNumber, 4) = Format(thisComment.DateTime, "dd-mmm-yyyy hh:mm")
                .Offset(commentNumber, 5) = thisComment.Text
            Next thisComment
        Next thisSlide
    End With

    ' Make the Excel workbook visible
    xlApp.Visible = True

    ' Clean up our objects
    Set xlWB = Nothing
    Set xlApp = Nothing
End Sub
...