MsgBox listing all outline level 1 headings

Dear Experts:
Below macro lists all outline level 1 headings in a msgbox. Can this macro be expanded to list also the paragraph style name in the msgbox such as:

Section 3: List of Tables, Heading_List
Section 4: List of Figures, Heading_List
Section 5: 1 Introduction, Heading 1
Section 6: 2 Analysis, Heading 1
........
Section 12: Bibliography, Heading_End
Section 13: Appendix, Heading_End

Help is much appreciated. Thank you very much in advance.

Regards, Andreas

Sub ListOutlineLevel1ParaMsgBox()
Dim oPara As Paragraph
Dim strMsg As String
Dim rTmp As range ' a temporary range
Dim lTmp As Long  ' sections count
Dim l2Tmp As Long
 
Set rTmp = ActiveDocument.range
'Create start of message
strMsg = "Outline Level 1: " & vbCr
'Iterate through all paragraphs in active document
'If style has outline level 1, append to message
For Each oPara In ActiveDocument.Paragraphs
   If oPara.OutlineLevel = wdOutlineLevel1 Then
'   strMsg = "Outline level 1: " & vbCr
 
      With oPara.range
      rTmp.End = .End ' redefine the temporary range
      lTmp = rTmp.Sections.count ' count the sections
     
      
      'Append the heading number and text to the message
      strMsg = strMsg & " section: " & CStr(lTmp)
      strMsg = strMsg & "  " & .ListFormat.ListString & "  " & .Text _
      & "  "
      
      End With
      End If
Next oPara
MsgBox strMsg, vbOKOnly, "Summary Outline Level 1"
End Sub

Select allOpen in new window