Чтение текста в сгруппированных объектах

Question

Я сделал презентацию (с Powerpoint 2016 в Windows 10), на которой к изображениям прикреплен текст.Я знаю VBA (не полностью) для Word или Excel, но я новичок в PP.Но грамматика Powerpoint смущает меня (это также будет для моего возраста).Я хочу извлечь все заголовки и текст всех слайдов, и по этому поводу я создаю следующую программу, которая прекрасно работает, но не дает мне знать текст сгруппированных объектов.Где я не прав?

Sub RiepilogaConWord()
Dim applWord As Word.Application
Dim docWord As Word.Document
Dim paraWord As Word.Paragraph
Dim oSh As Shape
Dim oSL As Slide

Set applWord = New Word.Application
applWord.Visible = True
applWord.WindowState = wdWindowStateMaximize
Set docWord = applWord.Documents.Add
docWord.ShowSpellingErrors = False
applWord.Selection.TypeText Text:="RIEPILOGO AL " & Format(Date, "dd/mm/YYYY") & " alle ore " & Format(Time, "hh:mm")
docWord.Paragraphs.Add
Set paraWord = docWord.Paragraphs(docWord.Paragraphs.Count)
paraWord.Range.InsertAfter "Totale diapositive " & Presentations(1).Slides.Count
docWord.Paragraphs.Add

For Each oSL In ActivePresentation.Slides
paraWord.Range.InsertAfter oSL.SlideIndex
docWord.Paragraphs.Add
Dim g As Integer
For Each oSh In oSL.Shapes
Select Case oSh.Type
Case Is = msoGroup
On Error Resume Next
oSh.Ungroup.Group , msoTextBox
For g = 1 To oSh.GroupItems.Count
If oSh.TextFrame.HasText Then
paraWord.Range.InsertAfter oSh.Name & ":= " & oSh.TextFrame.TextRange

End If
Next g
On Error GoTo errorhandler
Case Else
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
paraWord.Range.InsertAfter oSh.Name & ":= " & .TextFrame.TextRange

End If
End If
End With

        End Select
    Next
  Next   

docWord.SaveAs FileName:="C:\EPITETI CINQUE\Presentazione\RiepilogoPresentazione"

applWord.Quit

Set docWord = Nothing
Set applWord = Nothing
Set paraWord = Nothing
Exit Sub
errorhandler:
End Sub

Спасибо за любую помощь.Francesco

Answer 1

Несколько спорных вопросов здесь

• On Error Resume Next скрывает проблему от вас.Удалить его
• oSh.Ungroup.Group , msoTextBox не имеет смысла, я не знаю, что вы там пытаетесь сделать
• Когда вы найдете сгруппированный объект, выполните итерации его членов

Я реорганизовал ваш код для демонстрации.

• Я удалил материал Word, чтобы сделать Q более понятным, и просто сбросил текст в Immediate Window (Ctrl-G, чтобы отобразить его в редакторе VBA).Вы можете добавить его обратно ...
• добавлены комментарии к измененному коду, помечены <---
• Добавлен отступ, чтобы сделать код читабельным

---

Sub RiepilogaConWord()
    Dim oSh As Shape
    Dim oSL As Slide
    Dim g As Integer '<--- move here, no point in putting it in the loop, that does nothing

    '<--- Add here to use a general error.
    ' Comment it out while debugging to expose any errors
    ' On Error GoTo errorhandler handler

    For Each oSL In ActivePresentation.Slides
        For Each oSh In oSL.Shapes
            Select Case oSh.Type
                Case Is = msoGroup
                    'On Error Resume Next  '<--- Delete this
                    'oSh.Ungroup.Group , msoTextBox '<--- Delete this
                    For g = 1 To oSh.GroupItems.Count
                        With oSh.GroupItems.Item(g) '<--- simplify
                            '<--- use g to iterate the grouped items
                            If .HasTextFrame Then '<--- more robust
                                If .TextFrame.HasText Then
                                    Debug.Print .Name & ":= " & .TextFrame.TextRange
                                End If
                            End If
                        End With
                    Next g
                    'On Error GoTo errorhandler '<--- Delete this
                Case Else
                    With oSh
                        If .HasTextFrame Then
                            If .TextFrame.HasText Then
                                Debug.Print oSh.Name & ":= " & .TextFrame.TextRange
                            End If
                        End If
                    End With
            End Select
        Next
    Next
Exit Sub
errorhandler:
End Sub