Change font size and colour in footer through VBA

B

BigAnthony

Hi,

I am using the code below to transfer data from an Access 2003 table to be
displayed in PowerPoint.

Currently, it displays a footer, along with the date and slide number. How
do I go about adjusting the font size and colour of the text in the footer?

(Sorry about the line breaks)

Thanks,
Anthony


My Code here:
***********
Dim PPApp As Object 'late binding
Dim PPPres As Object
Dim PPSlide As Object
Dim db As Database, rs As Recordset
Dim strSql As String

Set PPApp = GetObject(, "PowerPoint.Application")

If PPApp Is Nothing Then 'no existing application is running
Set PPApp = CreateObject("PowerPoint.Application")
End If

If PPApp Is Nothing Then 'not able to create the application
MsgBox "The application is not available!",
vbExclamation+vbOKOnly,"Help."
End If

'Open up a recordset on the employee table.
Set db = CurrentDb
strSql = "SELECT * From [Employee] WHERE (Status = True);"
Set rs = db.OpenRecordset(strSql)
Set PPPres = PPApp.Presentations.Add
With PPApp
While Not rs.EOF
With PPPres.Slides
Set PPSlide = .Add(rs.AbsolutePosition + 1, 2)
PPSlide.HeadersFooters.Footer.Visible = True
PPSlide.HeadersFooters.Footer.Text = "My Footer Text Here."
PPSlide.HeadersFooters.DateAndTime.Visible = True
PPSlide.HeadersFooters.DateAndTime.UseFormat = True
PPSlide.HeadersFooters.DateAndTime.Format = 1
PPSlide.HeadersFooters.SlideNumber.Visible = True

PPSlide.Shapes(1).TextFrame.TextRange.Text =
UCase(CStr(rs.Fields("EmployeeID").value))

PPSlide.Shapes(2).TextFrame.TextRange.Text = "Name =
" & CStr(rs.Fields("FirstName").value) & vbCrLf & _
"Surname = " & CStr(rs.Fields("Surname").value)& vbCrLf & _
"Phone = " & CStr(rs.Fields("Phone").value) & vbCrLf & _
"Level = " & CStr(rs.Fields("Level").value)


PPSlide.Shapes(1).TextFrame.TextRange.Characters.Font.Size = 30

PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Size = 26

PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Color =
vbBlue

End With

rs.MoveNext

Wend

End With

PPPres.SlideShowSettings.Run

Set PPApp = Nothing
Set PPSlide = Nothing
Set PPPres = Nothing

End If

End If
 
V

vindys

Hi Anthony,

I doubt if you have any option to change color and size of footer using VBA
as its not provided using powerpoint

Thanks,
Vindys
 
B

BigAnthony

Chirag,

If it is possible, can you give me an example of the code I need?

I have adapted my code and it appears below.

Anthony



My Code here:
***********
Dim PPApp As Object 'late binding
Dim PPPres As Object
Dim PPSlide As Object
Dim mySlidesHF as object
Dim db As Database, rs As Recordset
Dim strSql As String

Set PPApp = GetObject(, "PowerPoint.Application")

If PPApp Is Nothing Then 'no existing application is running
Set PPApp = CreateObject("PowerPoint.Application")
End If

If PPApp Is Nothing Then 'not able to create the application
MsgBox "The application is not available!",
vbExclamation+vbOKOnly,"Help."
End If

'Open up a recordset on the employee table.
Set db = CurrentDb
strSql = "SELECT * From [Employee] WHERE (Status = True);"
Set rs = db.OpenRecordset(strSql)
Set PPPres = PPApp.Presentations.Add
With PPApp
Set mySlidesHF = PPPres.SlideMaster.HeadersFooters
With mySlidesHF
.Footer.Visible = True
.Footer.Text = "My Footer Here"
.SlideNumber.Visible = True
.DateAndTime.Visible = True
.DateAndTime.UseFormat = True
.DateAndTime.Format = 1
End With

While Not rs.EOF
With PPPres.Slides
Set PPSlide = .Add(rs.AbsolutePosition + 1, 2)

PPSlide.Shapes(1).TextFrame.TextRange.Text =
UCase(CStr(rs.Fields("EmployeeID").value))

PPSlide.Shapes(2).TextFrame.TextRange.Text = "Name =
" & CStr(rs.Fields("FirstName").value) & vbCrLf & _
"Surname = " & CStr(rs.Fields("Surname").value)& vbCrLf & _
"Phone = " & CStr(rs.Fields("Phone").value) & vbCrLf & _
"Level = " & CStr(rs.Fields("Level").value)

PPSlide.Shapes(1).TextFrame.TextRange.Characters.Font.Size
= 30
PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Size
= 26

PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Color =
vbBlue

End With

rs.MoveNext

Wend

End With

PPPres.SlideShowSettings.Run

Set PPApp = Nothing
Set PPSlide = Nothing
Set PPPres = Nothing
Set mySlidesHF = Nothing

End If

End If




Chirag said:
In Slide Master, look for shapes of type Placeholder. Footer is a
Placeholder of type ppPlaceholderFooter. You can look for it in
PlaceholderFormat.Type property.

- Chirag

PowerShow - View multiple PowerPoint slide shows simultaneously
http://officeone.mvps.org/powershow/powershow.html

BigAnthony said:
Hi,

I am using the code below to transfer data from an Access 2003 table to be
displayed in PowerPoint.

Currently, it displays a footer, along with the date and slide number. How
do I go about adjusting the font size and colour of the text in the
footer?

(Sorry about the line breaks)

Thanks,
Anthony


My Code here:
***********
Dim PPApp As Object 'late binding
Dim PPPres As Object
Dim PPSlide As Object
Dim db As Database, rs As Recordset
Dim strSql As String

Set PPApp = GetObject(, "PowerPoint.Application")

If PPApp Is Nothing Then 'no existing application is running
Set PPApp = CreateObject("PowerPoint.Application")
End If

If PPApp Is Nothing Then 'not able to create the application
MsgBox "The application is not available!",
vbExclamation+vbOKOnly,"Help."
End If

'Open up a recordset on the employee table.
Set db = CurrentDb
strSql = "SELECT * From [Employee] WHERE (Status = True);"
Set rs = db.OpenRecordset(strSql)
Set PPPres = PPApp.Presentations.Add
With PPApp
While Not rs.EOF
With PPPres.Slides
Set PPSlide = .Add(rs.AbsolutePosition + 1, 2)
PPSlide.HeadersFooters.Footer.Visible = True
PPSlide.HeadersFooters.Footer.Text = "My Footer Text
Here."
PPSlide.HeadersFooters.DateAndTime.Visible = True
PPSlide.HeadersFooters.DateAndTime.UseFormat = True
PPSlide.HeadersFooters.DateAndTime.Format = 1
PPSlide.HeadersFooters.SlideNumber.Visible = True

PPSlide.Shapes(1).TextFrame.TextRange.Text =
UCase(CStr(rs.Fields("EmployeeID").value))

PPSlide.Shapes(2).TextFrame.TextRange.Text = "Name =
" & CStr(rs.Fields("FirstName").value) & vbCrLf & _
"Surname = " & CStr(rs.Fields("Surname").value)& vbCrLf
& _
"Phone = " & CStr(rs.Fields("Phone").value) & vbCrLf & _
"Level = " & CStr(rs.Fields("Level").value)


PPSlide.Shapes(1).TextFrame.TextRange.Characters.Font.Size = 30

PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Size = 26

PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Color =
vbBlue

End With

rs.MoveNext

Wend

End With

PPPres.SlideShowSettings.Run

Set PPApp = Nothing
Set PPSlide = Nothing
Set PPPres = Nothing

End If

End If
Click to expand...
Click to expand...
 
J

John Wilson

Hi

I think Chiraq means you would need to look for the correct placeholder on
the master and then modify it. Something like this maybe

Dim oplc As Shape
For Each oplc In ActivePresentation.SlideMaster.Shapes
If oplc.Type = msoPlaceholder Then
If oplc.PlaceholderFormat.Type = ppPlaceholderFooter Then
With oplc.TextFrame.TextRange.Font
..Color = vbRed
..Size = 12
End With
End If
End If
Next oplc
--
-------------------------------------------
Amazing PPT Hints, Tips and Tutorials

http://www.PPTAlchemy.co.uk
http://www.technologytrish.co.uk
email john AT technologytrish.co.uk


BigAnthony said:
Chirag,

If it is possible, can you give me an example of the code I need?

I have adapted my code and it appears below.

Anthony



My Code here:
***********
Dim PPApp As Object 'late binding
Dim PPPres As Object
Dim PPSlide As Object
Dim mySlidesHF as object
Dim db As Database, rs As Recordset
Dim strSql As String

Set PPApp = GetObject(, "PowerPoint.Application")

If PPApp Is Nothing Then 'no existing application is running
Set PPApp = CreateObject("PowerPoint.Application")
End If

If PPApp Is Nothing Then 'not able to create the application
MsgBox "The application is not available!",
vbExclamation+vbOKOnly,"Help."
End If

'Open up a recordset on the employee table.
Set db = CurrentDb
strSql = "SELECT * From [Employee] WHERE (Status = True);"
Set rs = db.OpenRecordset(strSql)
Set PPPres = PPApp.Presentations.Add
With PPApp
Set mySlidesHF = PPPres.SlideMaster.HeadersFooters
With mySlidesHF
.Footer.Visible = True
.Footer.Text = "My Footer Here"
.SlideNumber.Visible = True
.DateAndTime.Visible = True
.DateAndTime.UseFormat = True
.DateAndTime.Format = 1
End With

While Not rs.EOF
With PPPres.Slides
Set PPSlide = .Add(rs.AbsolutePosition + 1, 2)

PPSlide.Shapes(1).TextFrame.TextRange.Text =
UCase(CStr(rs.Fields("EmployeeID").value))

PPSlide.Shapes(2).TextFrame.TextRange.Text = "Name =
" & CStr(rs.Fields("FirstName").value) & vbCrLf & _
"Surname = " & CStr(rs.Fields("Surname").value)& vbCrLf & _
"Phone = " & CStr(rs.Fields("Phone").value) & vbCrLf & _
"Level = " & CStr(rs.Fields("Level").value)

PPSlide.Shapes(1).TextFrame.TextRange.Characters.Font.Size
= 30
PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Size
= 26

PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Color =
vbBlue

End With

rs.MoveNext

Wend

End With

PPPres.SlideShowSettings.Run

Set PPApp = Nothing
Set PPSlide = Nothing
Set PPPres = Nothing
Set mySlidesHF = Nothing

End If

End If




Chirag said:
In Slide Master, look for shapes of type Placeholder. Footer is a
Placeholder of type ppPlaceholderFooter. You can look for it in
PlaceholderFormat.Type property.

- Chirag

PowerShow - View multiple PowerPoint slide shows simultaneously
http://officeone.mvps.org/powershow/powershow.html

BigAnthony said:
Hi,

I am using the code below to transfer data from an Access 2003 table to be
displayed in PowerPoint.

Currently, it displays a footer, along with the date and slide number. How
do I go about adjusting the font size and colour of the text in the
footer?

(Sorry about the line breaks)

Thanks,
Anthony


My Code here:
***********
Dim PPApp As Object 'late binding
Dim PPPres As Object
Dim PPSlide As Object
Dim db As Database, rs As Recordset
Dim strSql As String

Set PPApp = GetObject(, "PowerPoint.Application")

If PPApp Is Nothing Then 'no existing application is running
Set PPApp = CreateObject("PowerPoint.Application")
End If

If PPApp Is Nothing Then 'not able to create the application
MsgBox "The application is not available!",
vbExclamation+vbOKOnly,"Help."
End If

'Open up a recordset on the employee table.
Set db = CurrentDb
strSql = "SELECT * From [Employee] WHERE (Status = True);"
Set rs = db.OpenRecordset(strSql)
Set PPPres = PPApp.Presentations.Add
With PPApp
While Not rs.EOF
With PPPres.Slides
Set PPSlide = .Add(rs.AbsolutePosition + 1, 2)
PPSlide.HeadersFooters.Footer.Visible = True
PPSlide.HeadersFooters.Footer.Text = "My Footer Text
Here."
PPSlide.HeadersFooters.DateAndTime.Visible = True
PPSlide.HeadersFooters.DateAndTime.UseFormat = True
PPSlide.HeadersFooters.DateAndTime.Format = 1
PPSlide.HeadersFooters.SlideNumber.Visible = True

PPSlide.Shapes(1).TextFrame.TextRange.Text =
UCase(CStr(rs.Fields("EmployeeID").value))

PPSlide.Shapes(2).TextFrame.TextRange.Text = "Name =
" & CStr(rs.Fields("FirstName").value) & vbCrLf & _
"Surname = " & CStr(rs.Fields("Surname").value)& vbCrLf
& _
"Phone = " & CStr(rs.Fields("Phone").value) & vbCrLf & _
"Level = " & CStr(rs.Fields("Level").value)


PPSlide.Shapes(1).TextFrame.TextRange.Characters.Font.Size = 30

PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Size = 26

PPSlide.Shapes(2).TextFrame.TextRange.Characters.Font.Color =
vbBlue

End With

rs.MoveNext

Wend

End With

PPPres.SlideShowSettings.Run

Set PPApp = Nothing
Set PPSlide = Nothing
Set PPPres = Nothing

End If

End If
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Convert PowerPoint Reference to late Binding 11
Charts from EXCEL into PPT with .POT 1
Batch importing excel graphs into powerpoint presentation 3
VBA Public Function - Excel to PPT Stacked Chart, How to Remove Legends 0
Paste Excel Chart into Existing Powerpoint Chart 1
Early bind to Late bind 3
Early bound to Late bound 2
From Early bnind to Late bind 1

Top