Attribute VB_Name = "ToPowerPoint"
'Reference към Microsoft PowerPoint ?.? Object Library
Option Explicit
Sub makePPt() 'Създаване на слайдовете с въпросите
 Dim ppt As New PowerPoint.Application 'Обект от тип "Апликация на PowerPoint"
 Dim pp As PowerPoint.Presentation 'Указател към обект от тип "Презентация"
 Dim sl As PowerPoint.Slide 'Указател обект от тип "Слайд"
 Dim p As Paragraph 'Указател към обект от тип "Абзац на Word"
 'Помощни променливи
 Dim i As Integer, s As String
 Dim j As Integer
 Dim ob As Object
 Dim slW As Single, slH As Single 'За размерите на слайдовете
 
 Set pp = ppt.Presentations.Add 'Създаване на нова презентация
 slW = pp.PageSetup.SlideWidth  'Широчина на слайдовете
 slH = pp.PageSetup.SlideHeight 'Височина на слайдовете
 i = 1 'Брояч на слайдовете
 For Each p In ActiveDocument.Paragraphs 'Обхождане на параграфите в ActiveDocument
  'Разпознаване на следващ въпрос: ако параграфът започва с цифра
  s = p.Range.Characters(1).Text 'Първи символ в параграфа
  If s >= "1" And s <= "9" Then  'Ако е нов въпрос...
   Set sl = pp.Slides.Add(i, ppLayoutBlank) '...добавяне на нов слайд
   i = i + 1
   j = 1
   'Добавяне на TextBox с въпроса
   With sl.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 30, slW - 10, slH / 3)
    .TextFrame.TextRange.Font.Name = "Times New Roman"
    .TextFrame.TextRange.Font.Size = 30
    .TextFrame.TextRange.Text = p.Range.Text 'Текст на въпроса
   End With
  Else 'Ако не е въпрос - добавяне на нов OptionButton (с номер j) върху текущия слайд
   Set ob = sl.Shapes.AddOLEObject(60, slH / 3 + 50 * j, slW - 60, 40, "Forms.OptionButton.1")
   With ob.OLEFormat.Object
    .Font.Name = "Times New Roman"
    .Font.Size = 30
    .Caption = p.Range.Text 'Текст на възможния отговор
   End With
   j = j + 1 'Следващ номер на възможния отговор
  End If
 Next
 'Намиране на пътя за достъп до текущия документ
 s = ThisDocument.Path
 If Right(s, 1) <> "\" Then s = s & "\"
 pp.SaveAs s & "Test1" 'Запис на презентацията по име Test1.pptx
 pp.Close 'Затваряне на текущата презентация
 ppt.Quit 'Край на работата с апликацията на PowerPoint
End Sub