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

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]