[Презентация] Sub CreatePresentation() Dim pptApp As Object Dim pptPres As Object Dim pptSlide As Object Dim doc As Document Dim para As Paragraph Dim slideCount As Integer Dim slideTitle As String Dim slideContent As String ' Initialize PowerPoint application On Error Resume Next Set pptApp = GetObject(, "PowerPoint.Application") If pptApp Is Nothing Then Set pptApp = CreateObject("PowerPoint.Application") On Error GoTo 0 ' Make PowerPoint visible pptApp.Visible = True ' Create a new presentation Set pptPres = pptApp.Presentations.Add ' Open the Word document Set doc = Application.Documents.Open("C:\\Path\\To\\Your\\Document.docx") ' Update with your file path slideCount = 1 slideTitle = "" slideContent = "" ' Loop through paragraphs in the Word document For Each para In doc.Paragraphs If para.Range.Style Like "Heading*" Then ' Add the previous slide if it exists If slideTitle <> "" Or slideContent <> "" Then Set pptSlide = pptPres.Slides.Add(slideCount, ppLayoutText) pptSlide.Shapes(1).TextFrame.TextRange.Text = slideTitle pptSlide.Shapes(2).TextFrame.TextRange.Text = slideContent slideContent = "" End If ' Set the new slide title slideTitle = para.Range.Text Else ' Append paragraph text to slide content slideCount = slideCount + 1 slideContent = slideContent & para.Range.Text & vbCrLf End If Next para ' Add the final slide If slideTitle <> "" Or slideContent <> "" Then Set pptSlide = pptPres.Slides.Add(slideCount, ppLayoutText) pptSlide.Shapes(1).TextFrame.TextRange.Text = slideTitle pptSlide.Shapes(2).TextFrame.TextRange.Text = slideContent End If ' Clean up doc.Close SaveChanges:=False Set doc = Nothing MsgBox "Presentation created successfully!" End Sub