Article ID: 139880
Article Last Modified on 10/11/2006
Sub PowerPointOLEAutomation()
Dim PPT As Object
Dim Pres As PowerPoint.Presentation
Dim Slide1 As PowerPoint.Slide
Dim Slide2 As PowerPoint.Slide
Dim Slide3 As PowerPoint.Slide
Dim Slide4 As PowerPoint.Slide
Dim i as integer
'creates the PowerPoint Object
Set PPT = CreateObject("powerpoint.application.7")
PPT.AppWindow.Visible = True 'Makes PowerPoint visible
Set Pres = PPT.Presentations.Add 'Adds a blank presentation
'adds a blank slide
Set Slide1 = Pres.Slides.Add(1, ppLayoutBlank)
Set Slide2 = Pres.Slides.Add(2, ppLayoutBlank)
Set Slide3 = Pres.Slides.Add(3, ppLayoutBlank)
Set Slide4 = Pres.Slides.Add(4, ppLayoutBlank)
'you can use universal naming convention (UNC) to point to network share
'adds a graphic image to the slide
'these need to be on a separate line
Slide1.Background.Fill.PresetShaded ppPresetShadeEarlySunset, 1, 1
Slide2.Background.Fill.PresetShaded ppPresetShadeDaybreak, 1, 1
Slide3.Background.Fill.PresetShaded ppPresetShadeMahogany, 1, 1
Slide4.Background.Fill.PresetShaded ppPresetShadeNightfall, 1, 1
For i = 1 To 4 'starts a FOR loop
With Pres.Slides(i)
.Objects.AddTextFrame 5000, 0, 5000 'adds a text frame
Select Case i
Case 1
'enters text into the text frame
.Objects(1).Text = "Today is " & _
Format(Date, "mm/dd/yy")
Case 2
.Objects(1).Text = "This Is Just A Test"
Case 3
.Objects(1).Text = "Please Do Not Be Alarmed"
Case 4
.Objects(1).Text = "Everything Is OK"
End Select
'sets characteristics for the font
With .Objects(1).Text.Font
'screen measurements are done in Twips,
'multiply by 20 to get normal pixel size
.Size = 50 * 20
.Bold = ppTrue
.Shadow = ppTrue
End With
'center aligns the text
.Objects(1).Text.ParaFormat.Alignment = ppAlignCenter
End With
Next i
'copies a chart
ThisWorkbook.Worksheets(1).DrawingObjects("Chart 1").CopyPicture
PPT.ActiveWindow.View.Paste 'pastes the chart
'runs a Slide Show presentation
Pres.SlideShow.Run (ppSlideShowFullScreen)
'clears the object variable
Set PPT = Nothing 'This does not close the application
End Sub
A1: 1
A2: 2
A3: 3
Additional query words: PUB_PP powerpt XL7
Keywords: kbprogramming KB139880