Consulting

Results 1 to 2 of 2

Thread: Solved: Automated Slide Project

  1. #1
    VBAX Tutor jamescol's Avatar
    Joined
    May 2004
    Location
    Charlotte, NC
    Posts
    251
    Location

    Solved: Automated Slide Project

    I was tired of seeing nothing in the Powerpoint forum. I've been thinking about automating a frequently-used slide format, but haven't had time to dig into it. Maybe some of you can help get it started.

    So here's what I need when the user runs the macro:

    1. Create a new blank slide
    2. Prompt for a slide title and subtitle and center them at the top of the slide
    3. Draw two lines dividing the slide into 4 equal quadrants
    4. For each quadrant:
    Prompt for a title and center the title in that quadrant
    Prompt the user for 5-6 bulleted items and display them left aligned under
    the quadrant's title.

    Anyone up for this?

    James
    "All that's necessary for evil to triumph is for good men to do nothing."

  2. #2
    VBAX Tutor jamescol's Avatar
    Joined
    May 2004
    Location
    Charlotte, NC
    Posts
    251
    Location
    So nobody was willing to step up to the challenge, eh? OK, here is what I have thus far. Not polished, but gets me everything I needed on my list except:

    #2 - Subtitle
    #4 - User-prompted quadrant titles

    General Declarations section:

    [vba]
    Const INPUT_SLIDETITLE_PROMPT = "Enter a Slide Title."
    Const INPUT_SLIDETITLE_TITLE = "Slide Title"
    Const MSG_ERR_TITLE = "Error!"
    Const MSG_ERR_PROMPT = "An error occurred! Please report the error message to James"
    Const MSG_SLIDETITLE_ERR_PROMPT = "You did not enter a title. Either enter a title or click Cancel to exit"
    Const MSG_SLIDETITLE_ERR_TITLE = "Title Not Entered"
    Const sBLANK = ""

    [/vba]

    Procedure Code:

    [vba]
    Sub Create4Block()
    Dim sTopCenter, sHeight, sLeftCenter, sLength, iReturn As Integer
    Dim mySlide As Slide
    Dim sPrompt, sInputReturn, sMsgReturn As String
    Dim sglFrameWidth, sglFrameHeight, sglFrameUpperPosition, sglFrameLowerPosition, sglFrameLeftPosition, sglFrameRightPosition As Single


    'Set the texframe size
    'Size is in points, so multiply inches by 72 to get point size
    sglFrameWidth = 4.83 * 72
    sglFrameHeight = 2.67 * 72

    'Set the texframe positions
    sglFrameUpperPosition = 2 * 72 'Q1 & Q4 Top
    sglFrameLowerPosition = 4.83 * 72 'Q2 & Q3 Top
    sglFrameLeftPosition = 0.58 * 72 'Q3 & Q4 Left
    sglFrameRightPosition = 5.59 * 72 'Q1 & Q2 Left

    'Set an object for the active slide
    Set mySlide = ActivePresentation.Slides(1)

    With Application.ActivePresentation.PageSetup

    On Error GoTo errhandler

    'Set the slide size to 8.5" x 11" landscape
    .SlideWidth = 11 * 72
    .SlideHeight = 8.5 * 72
    sHeight = .SlideHeight
    sLength = .SlideWidth

    sTopCenter = .SlideWidth / 2
    sLeftCenter = (.SlideHeight / 2) + 36

    End With

    'Set the indention levels for each text-based shape
    'For some reason, setting these properties on a single textframe
    'sets them for all textframes. Need to find out why.

    With ActivePresentation.SlideMaster.Shapes(2) _
    .TextFrame.Ruler
    .Levels(1).FirstMargin = 0
    .Levels(1).LeftMargin = 40

    .Levels(2).FirstMargin = 60
    .Levels(2).LeftMargin = 100
    .Levels(3).FirstMargin = 120
    .Levels(3).LeftMargin = 160
    .Levels(4).FirstMargin = 180
    .Levels(4).LeftMargin = 220
    .Levels(5).FirstMargin = 240
    .Levels(5).LeftMargin = 280
    End With

    With mySlide

    'Set the slide layout
    .Layout = ppLayoutTitleOnly

    'Set the slide title
    Do
    sInputReturn = InputBox(INPUT_SLIDETITLE_PROMPT, INPUT_SLIDETITLE_TITLE)

    'User did not enter a title
    If sInputReturn = sBLANK Then

    'Tell the user to enter a title or click cancel to quit
    sMsgReturn = MsgBox(MSG_SLIDETITLE_ERR_PROMPT, vbExclamation + vbOKCancel, MSG_SLIDETITLE_ERR_TITLE)

    'User clicked cancel, so cleanup and close the presentation
    If sMsgReturn = vbCancel Then
    Set mySlide = Nothing
    Application.Presentations.Item(1).Close
    Exit Sub
    Else
    .Shapes.Title.TextFrame.TextRange.Text = sInputReturn
    End If
    End If

    Loop While sInputReturn = sBLANK



    End With

    'Add the 4 TextFrames to the slide
    With mySlide
    'Quad 1 TextFrame

    With .Shapes _
    .AddShape(msoShapeRectangle, sglFrameRightPosition, sglFrameUpperPosition, sglFrameWidth, sglFrameHeight).TextFrame
    .TextRange.Text = "Click here to add text"
    .MarginTop = 10
    .WordWrap = True
    End With

    'Quad 2 TextFrame
    With .Shapes _
    .AddShape(msoShapeRectangle, sglFrameRightPosition, sglFrameLowerPosition, 4.83 * 72, 2.67 * 72).TextFrame

    .TextRange.Text = "Click here to add text"
    .MarginTop = 10
    .WordWrap = True
    End With

    'Quad 3 TextFrame
    With .Shapes _
    .AddShape(msoShapeRectangle, sglFrameLeftPosition, sglFrameLowerPosition, 4.83 * 72, 2.67 * 72).TextFrame

    .TextRange.Text = "Click here to add text"
    .MarginTop = 10
    .WordWrap = True
    End With


    'Quad 4 TextFrame
    With .Shapes _
    .AddShape(msoShapeRectangle, sglFrameLeftPosition, sglFrameUpperPosition, 4.83 * 72, 2.67 * 72).TextFrame
    .TextRange.Text = "Click here to add text"
    .MarginTop = 10
    .WordWrap = True

    End With

    End With

    'Set each TextFrame's properties
    'I'm sure there is a global method to this, and I just haven't figured it out yet!

    For i = 2 To 5 'The first TextFrame is the 2nd shape, so start with i=2

    With mySlide.Shapes(i)
    .Fill.Background
    .Line.Visible = msoFalse
    .Name = "Quad" & i

    With .TextFrame
    .VerticalAnchor = msoAnchorTop

    With .TextRange
    .Paragraphs(1).Lines(1).Font.Bold = msoTrue
    .Paragraphs(1).Lines(1).ParagraphFormat.Alignment = ppAlignCenter
    .Paragraphs(1).Lines(1).ParagraphFormat.Bullet = msoFalse


    With .ParagraphFormat
    .Alignment = ppAlignLeft


    With .Bullet
    .Visible = True
    .Character = 183
    .RelativeSize = 1.25
    .Font.Color.RGB = RGB(0, 0, 0)
    .Font.Name = "Symbol"

    End With
    End With
    End With
    End With

    End With

    Next i


    'Add the vertical line
    With ActivePresentation.Slides.Item(1).Shapes.AddLine(BeginX:=sTopCenter, BeginY:=(sHeight - (sHeight - 144)), _
    EndX:=sTopCenter, EndY:=sHeight - 60).Line
    .DashStyle = msoLineSolid
    .ForeColor.RGB = RGB(50, 0, 128)
    End With

    'Add the horizontal line
    With ActivePresentation.Slides.Item(1).Shapes.AddLine(BeginX:=sLength - (sLength - 36), BeginY:=(sLeftCenter), _
    EndX:=sLength - 36, EndY:=sLeftCenter).Line
    .DashStyle = msoLineSolid
    .ForeColor.RGB = RGB(50, 0, 128)
    End With

    Exit Sub



    errhandler:
    'Build MsgBox prompt

    sPrompt = MSG_ERR_PROMPT & Chr(13) & Chr(13) & "Error Number: " & Err.Number & Chr(13) _
    & "Description: " & Err.Description


    iReturn = MsgBox(sPrompt, vbCritical, MSG_ERR_TITLE)

    End Sub

    [/vba]
    "All that's necessary for evil to triumph is for good men to do nothing."

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •