K
Kennya1
I posted this in the VSTO group but they suggested I Posti it here
Writting a ribbonbar addin in
vb2008 to change the background of an indivdual slide. This program
does it for all slides NOT the SELECTED SLIDES
How come?
On Error GoTo NoBackgroundFound
Dim ActWinSlideRange As
Microsoft.Office.Interop.PowerPoint.SlideRange
Dim ActWinSlidePresentation As
Microsoft.Office.Interop.PowerPoint.Presentation
ActWinSlideRange =
PowerPointAddIn1.Globals.Ribbon2008.Application.ActiveWindow.Presentation.Slides.Range()
ActWinSlidePresentation =
PowerPointAddIn1.Globals.Ribbon2008.Application.ActiveWindow.Presentation
With ActWinSlideRange
.FollowMasterBackground =
Microsoft.Office.Core.MsoTriState.msoFalse
.DisplayMasterShapes =
Microsoft.Office.Core.MsoTriState.msoTrue
With .Background
.Fill.Visible =
Microsoft.Office.Core.MsoTriState.msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.SchemeColor =
PowerPoint.PpColorSchemeIndex.ppShadow
.Fill.Transparency = 0.0#
If InStr(ActWinSlidePresentation.Name, ".pptm") > 0
Then
.Fill.UserPicture("C:\My
Documents\Powerpoint\Background\" &
Replace(ActWinSlidePresentation.Name, ".pptm", "") & "\Ultra
Background Slide.jpg")
Else
.Fill.UserPicture("C:\My
Documents\Powerpoint\Background\" &
Replace(ActWinSlidePresentation.Name, ".ppt", "") & "\Ultra Background
Slide.jpg")
End If
End With
End With
Exit Sub
NoBackgroundFound:
MsgBox("No Background Found")
End Sub
THe Working VBA Code is
Sub UltraSlide()
On Error GoTo NoBackgroundFound
If ActiveWindow.Presentation.Name <> "GNYDM 2005.ppt" And
ActiveWindow.Presentation.Name <> "GNYDM 2005 Workshop.ppt" Then
With ActiveWindow.Selection.SlideRange
.FollowMasterBackground = msoFalse
.DisplayMasterShapes = msoTrue
With .Background
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.SchemeColor = ppShadow
.Fill.Transparency = 0#
If InStr(ActiveWindow.Presentation.Name, ".pptm") > 0
Then
.Fill.UserPicture "C:\My
Documents\Powerpoint\Background\" &
Replace(ActiveWindow.Presentation.Name, ".pptm", "") & "\Ultra
Background Slide.jpg"
Else
.Fill.UserPicture "C:\My
Documents\Powerpoint\Background\" &
Replace(ActiveWindow.Presentation.Name, ".ppt", "") & "\Ultra
Background Slide.jpg"
End If
End With
End With
Else
Call Three
' With ActiveWindow.Selection.SlideRange
' .ApplyTemplate FileName:="C:\My
Documents\Powerpoint\Background\" &
Replace(ActiveWindow.Presentation.Name, ".ppt", "") & "\Ultra
Background Slide.pot"
' '.ApplyTemplate FileName:="C:\My
Documents\Powerpoint\GNYDM 2005\Templates\GNYDM High Tech Ultra.pot"
' End With
End If
Exit Sub
NoBackgroundFound:
MsgBox ("No Background Found")
End Sub
Writting a ribbonbar addin in
vb2008 to change the background of an indivdual slide. This program
does it for all slides NOT the SELECTED SLIDES
How come?
On Error GoTo NoBackgroundFound
Dim ActWinSlideRange As
Microsoft.Office.Interop.PowerPoint.SlideRange
Dim ActWinSlidePresentation As
Microsoft.Office.Interop.PowerPoint.Presentation
ActWinSlideRange =
PowerPointAddIn1.Globals.Ribbon2008.Application.ActiveWindow.Presentation.Slides.Range()
ActWinSlidePresentation =
PowerPointAddIn1.Globals.Ribbon2008.Application.ActiveWindow.Presentation
With ActWinSlideRange
.FollowMasterBackground =
Microsoft.Office.Core.MsoTriState.msoFalse
.DisplayMasterShapes =
Microsoft.Office.Core.MsoTriState.msoTrue
With .Background
.Fill.Visible =
Microsoft.Office.Core.MsoTriState.msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.SchemeColor =
PowerPoint.PpColorSchemeIndex.ppShadow
.Fill.Transparency = 0.0#
If InStr(ActWinSlidePresentation.Name, ".pptm") > 0
Then
.Fill.UserPicture("C:\My
Documents\Powerpoint\Background\" &
Replace(ActWinSlidePresentation.Name, ".pptm", "") & "\Ultra
Background Slide.jpg")
Else
.Fill.UserPicture("C:\My
Documents\Powerpoint\Background\" &
Replace(ActWinSlidePresentation.Name, ".ppt", "") & "\Ultra Background
Slide.jpg")
End If
End With
End With
Exit Sub
NoBackgroundFound:
MsgBox("No Background Found")
End Sub
THe Working VBA Code is
Sub UltraSlide()
On Error GoTo NoBackgroundFound
If ActiveWindow.Presentation.Name <> "GNYDM 2005.ppt" And
ActiveWindow.Presentation.Name <> "GNYDM 2005 Workshop.ppt" Then
With ActiveWindow.Selection.SlideRange
.FollowMasterBackground = msoFalse
.DisplayMasterShapes = msoTrue
With .Background
.Fill.Visible = msoTrue
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Fill.BackColor.SchemeColor = ppShadow
.Fill.Transparency = 0#
If InStr(ActiveWindow.Presentation.Name, ".pptm") > 0
Then
.Fill.UserPicture "C:\My
Documents\Powerpoint\Background\" &
Replace(ActiveWindow.Presentation.Name, ".pptm", "") & "\Ultra
Background Slide.jpg"
Else
.Fill.UserPicture "C:\My
Documents\Powerpoint\Background\" &
Replace(ActiveWindow.Presentation.Name, ".ppt", "") & "\Ultra
Background Slide.jpg"
End If
End With
End With
Else
Call Three
' With ActiveWindow.Selection.SlideRange
' .ApplyTemplate FileName:="C:\My
Documents\Powerpoint\Background\" &
Replace(ActiveWindow.Presentation.Name, ".ppt", "") & "\Ultra
Background Slide.pot"
' '.ApplyTemplate FileName:="C:\My
Documents\Powerpoint\GNYDM 2005\Templates\GNYDM High Tech Ultra.pot"
' End With
End If
Exit Sub
NoBackgroundFound:
MsgBox ("No Background Found")
End Sub