Hi Jacob,
I have tried to create the code by my own, but it didnt work (what a surprise, hum?? ).
Well, anyway to code is here if can help me out.
Sub Macro1()
Dim AppPPT As Object
Dim Pre As Object
Set AppPPT = CreateObject("Powerpoint.Application")
Set Pre = AppPPT.Presentations.Add
AppPPT.Visible = True
With AppPPT
.ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add(Index:=1, Layout:=ppLayoutTitle).SlideIndex
.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
With .ActiveWindow.Selection.TextRange
.text = "Presentation"
With .Font
.Name = "Arial"
.Size = 44
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppTitle
End With
End With
.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
With .ActiveWindow.Selection.TextRange
.text = "Presenter"
With .Font
.Name = "Arial"
.Size = 32
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With
End With
.ActiveWindow.Selection.Unselect
.ActiveWindow.View.GotoSlide Index:=ActivePresentation.Slides.Add(Index:=2, Layout:=ppLayoutText).SlideIndex
.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 2").Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
With .ActiveWindow.Selection.TextRange
.text = "Title text"
With .Font
.Name = "Arial"
.Size = 44
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppTitle
End With
End With
.ActiveWindow.Selection.SlideRange.Shapes("Rectangle 3").Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Select
.ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=0).Select
With .ActiveWindow.Selection.TextRange
.text = "Item 1" + Chr$(CharCode:=13) + "Item 2"
With .Font
.Name = "Arial"
.Size = 32
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With
End With
.ActiveWindow.Selection.Unselect
.ActivePresentation.SaveAs Filename:="C:\Documents and Settings\PALEO\My documents\test.ppt"
End With
End Sub