Mcro For Generate Power Point Presentation From Word

• Tweet
• 

        This macro produces, from a Word document, Powerpoint slides, provided you follow a few simple rules:
- The document must be entitled,
- levels 1 and 2 produce a slide,
- level 3 produce a bulletted text box,
- paraghraph with name starting by pptInsert are inserted in slide above title,
- word fragment bookmarked (These may be images, text or tables) are inserted in slide.
The presentation is created in the same directory of the Word document and whit the same name. 

Sub genPowerPoint()
' aStruct: level,start paragraphe, end paragraph
' for level 1 and 2
Dim aStruct(200) As String
nEl = 0
sep = ","   ' Chr$(255)
maxLevel = 3    ' max level listed in slide text box
titleLevel = 2  ' max level in titles
iParCount = ActiveDocument.Paragraphs.Count
For i = 1 To iParCount
    Style = ActiveDocument.Paragraphs(i).Range.Style
    If Left(Style, 6) = "Titolo" Or Left(Style, 7) = "Heading" Then
        Level = ActiveDocument.Paragraphs(i).Range.ListFormat.ListLevelNumber
        If Level <= titleLevel Then
            nEl = nEl + 1
            txt = ActiveDocument.Paragraphs(i).Range.FormattedText
            aStruct(nEl) = Level & sep & i
            If nEl > 1 Then aStruct(nEl - 1) = aStruct(nEl - 1) & "," & i - 1
        End If
    End If
Next
aStruct(nEl) = aStruct(nEl) & "," & i - 1
sFile = Application.ActiveDocument
sFile = Application.ActiveDocument.Path & "\" & Left(sFile, Len(sFile) - 4) & ".ppt"
Set oPA = CreateObject("PowerPoint.Application")
oPA.Visible = True
ppLayoutTitle = 1
ppLayoutText = 2
ppLayoutTextAndObject = 13
ppLayoutObject = 16
ppLayoutTitleOnly = 11
ppAutoSizeShapeToFitText = 1
Set oRg = ActiveDocument.Range
Set oPP = oPA.Presentations.Add(msoTrue)
With oPP.PageSetup
    hSlide = .SlideHeight
    wSlide = .SlideWidth
End With
For J = 1 To nEl
    aData = Split(aStruct(J), ",")
    aRes = searchData(aData, maxLevel)
    intSlides = 0   ' to find layout type
    If aRes(0) <> "" Then intSlides = intSlides + 1
    If aRes(1) <> "" Then intSlides = intSlides + 2
    If aRes(2) > 0 Then intSlides = intSlides + 4
    oPP.Slides.Add oPP.Slides.Count + 1, ppLayoutTitleOnly
    Set oPS = oPP.Slides(oPP.Slides.Count)
    hNewTextbox = oPS.Shapes("Rectangle 2").Top + oPS.Shapes("Rectangle 2").Height '   follow text boxes
    oPS.Shapes("Rectangle 2").TextFrame.TextRange.Text = removeLastByte(ActiveDocument.Paragraphs(aData(1)).Range.FormattedText)
    If (aRes(1) <> "") Then
        Set oShape = oPS.Shapes.AddTextbox(msoTextOrientationHorizontal, 50#, hNewTextbox + 10, wSlide - 100, 100)
        Set shapetext = oShape.TextFrame.TextRange
        shapetext.Text = removeLastByte(aRes(1))
        shapetext.Font.Name = aRes(3)
        oShape.TextFrame.AutoSize = ppAutoSizeShapeToFitText
        hNewTextbox = oShape.Top + oShape.Height
    End If
    If aRes(0) <> "" Then
        wtextBox = IIf(aRes(2) > 0, (wSlide - 100) / 2, wSlide - 100)
        Set oShape = oPS.Shapes.AddTextbox(msoTextOrientationHorizontal, 50#, hNewTextbox + 10, wtextBox, 100)
        Set shapetext = oShape.TextFrame.TextRange
        shapetext.Text = removeLastByte(aRes(0))
        shapetext.ParagraphFormat.Bullet.Visible = msoTrue
        ' this is not working
        oShape.TextFrame.AutoSize = True    'ppAutoSizeShapeToFitText
    End If
    If aRes(2) > 0 Then
        nTextBoxAfter = oPP.Slides(oPP.Slides.Count).Shapes.Count
        Set oBookMark = ActiveDocument.Paragraphs(aRes(2)).Range.Bookmarks(1)
        oBookMark.Select
        oBookMark.Range.CopyAsPicture
        oPP.Slides(oPP.Slides.Count).Shapes.Paste
        nTextBox = oPP.Slides(oPP.Slides.Count).Shapes.Count
        For i = nTextBoxAfter + 1 To nTextBox
            With oPP.Slides(oPP.Slides.Count).Shapes(i)
                .Top = hNewTextbox + 10
                .Left = IIf(aRes(0) = "", 50, 50 + (wSlide - 100) / 2)
                .Width = IIf(aRes(0) = "", wSlide - 100, (wSlide - 100) / 2)
            End With
        Next
    End If
Next
oPP.SaveAs sFile
oPP.Close
oPA.Quit
End Sub
Public Function searchData(aEl, maxLevel)   ' search sub levels, pptInsert text and table
Dim aRet(4)
aRet(0) = "" ' list of headings
aRet(1) = "" ' list of pptInsert
aRet(2) = 0 ' paragraph with table
aRet(3) = "" ' Font type of pptInsert
For J = aEl(1) + 1 To aEl(2)
    Style = ActiveDocument.Paragraphs(J).Range.Style    ' ActiveDocument.Paragraphs(i).Range.ListFormat.ListLevelNumber
    If (Left(Style, 6) = "Titolo" Or Left(Style, 7) = "Heading") _
        And ActiveDocument.Paragraphs(J).Range.ListFormat.ListLevelNumber <= maxLevel Then
        aRet(0) = aRet(0) & " " & removeLastByte(ActiveDocument.Paragraphs(J).Range.FormattedText) & Chr(13)
    End If
    If Left(Style, 9) = "pptInsert" Then
        aRet(1) = aRet(1) & removeLastByte(ActiveDocument.Paragraphs(J).Range.FormattedText) & Chr(13)
        aRet(3) = ActiveDocument.Paragraphs(J).Range.FormattedText.Font.Name
    End If
    If ActiveDocument.Paragraphs(J).Range.Bookmarks.Count > 0 Then aRet(2) = J ' paragraph with table
Next
searchData = aRet
End Function
Public Function removeLastByte(txt)
If Len(txt) > 1 Then
    removeLastByte = Left(txt, Len(txt) - 1)
Else
    removeLastByte = ""
End If
End Function

Tags:
• 2000
• office
• point
• power
• Word