I want to delete any animation of my two text boxes (TextBox_A, TextBox_B) then add a fade animation & a font colour change.
The font colour changed text in TextBox_A & 2nd/remaining text in TextBox_B changed to the default colour (orange).
Dim oeff As Effect
Dim gShp As Shape
Dim tShp As Shape
Dim C As Long
Dim X As Long
Dim osld As Slide
Set osld = ActivePresentation.Slides(1)
Set gShp = osld.Shapes("TextBox_A")
For C = osld.TimeLine.MainSequence.Count To 1 Step -1
If osld.TimeLine.MainSequence(C).Shape.Id = gShp.Id Then
osld.TimeLine.MainSequence(C).Delete
End If
Next C
Set oeff = osld.TimeLine.MainSequence.AddEffect(Shape:=gShp, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerWithPrevious)
oeff.Timing.TriggerDelayTime = 0
oeff.Timing.Duration = 0.75
Set oeff = osld.TimeLine.MainSequence.AddEffect(Shape:=gShp, effectid:=msoAnimEffectChangeFontColor, trigger:=msoAnimTriggerWithPrevious)
oeff.EffectParameters.Color2.RGB = RGB(127, 127, 127)
oeff.Timing.TriggerDelayTime = 7.5
oeff.Timing.Duration = 0.1
Set tShp = osld.Shapes("TextBox_B")
For C = osld.TimeLine.MainSequence.Count To 1 Step -1
If osld.TimeLine.MainSequence(C).Shape.Id = tShp.Id Then
osld.TimeLine.MainSequence(C).Delete
End If
Next C
Set oeff = osld.TimeLine.MainSequence.AddEffect(Shape:=tShp, effectid:=msoAnimEffectFade, trigger:=msoAnimTriggerWithPrevious)
oeff.Timing.TriggerDelayTime = 0
oeff.Timing.Duration = 0.75
Set oeff = osld.TimeLine.MainSequence.AddEffect(Shape:=tShp, effectid:=msoAnimEffectChangeFontColor, trigger:=msoAnimTriggerWithPrevious)
oeff.EffectParameters.Color2.RGB = RGB(0, 0, 0)
oeff.Timing.TriggerDelayTime = 7.5
oeff.Timing.Duration = 0.1
Related
Trying to create a 2 color gradient in a powerpoint macro. The second color keeps showing up as white. I saw another question on here about the same problem but the answer didn't work for me. Can anyone spot my issue? Thanks in advance!
Dim Sld As Slide
Dim Shp As Shape
Set Sld = Application.ActiveWindow.View.Slide
'TIMELINE BOX
Set Shp = Sld.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=-5, Top:=0, Width:=365, Height:=50)
'Shape Name
Shp.Name = "DateBox1"
'No Shape Border
Shp.Line.Visible = msoTrue
Shp.Line.Weight = 2
Shp.Line.ForeColor.RGB = RGB(255, 255, 255)
'Shape Fill Color
Shp.Fill.Visible = msoTrue
Shp.Fill.ForeColor.RGB = RGB(18, 115, 57)
Shp.Fill.BackColor.RGB = RGB(72, 166, 105)
Shp.Fill.TwoColorGradient msoGradientHorizontal, 2
'Shp.Fill.GradientStops.Item(1).Position = 50
Shp.Fill.RotateWithObject = msoTrue
'Shape Text Color
Shp.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
'Text inside Shape
Shp.TextFrame.TextRange.Characters.Text = "DATE"
'Center Align Text
Shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
'Vertically Align Text to Middle
Shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
'Adjust Font Size
Shp.TextFrame2.TextRange.Font.Size = 22
Shp.TextFrame2.TextRange.Font.Name = "Myriad Pro"
Shp.TextFrame2.TextRange.Font.Bold = True
Shp.TextFrame2.TextRange.Font.Shadow.Type = msoShadow1
Shp.TextFrame2.TextRange.Font.Shadow.OffsetX = 10
Shp.TextFrame2.TextRange.Font.Shadow.OffsetY = 10
Shp.TextFrame2.TextRange.Font.Shadow.Size = 1
Shp.TextFrame2.TextRange.Font.Shadow.Blur = 4
Shp.TextFrame2.TextRange.Font.Shadow.Transparency = 0.5
Shp.TextFrame2.TextRange.Font.Shadow.Visible = True
'Shadow
Shp.Shadow.Type = msoShadow1
Shp.Shadow.ForeColor.RGB = RGB(0, 0, 0)
Shp.Shadow.Transparency = 0.7
Shp.Shadow.OffsetX = 2
Shp.Shadow.OffsetY = 2
Shp.Shadow.Blur = 60
Set the gradient fill first, then set the colors:
Shp.Fill.TwoColorGradient msoGradientHorizontal, 2
Shp.Fill.ForeColor.RGB = RGB(18, 115, 57)
Shp.Fill.BackColor.RGB = RGB(72, 166, 105)
I created a graph in VBA
But i want to the last point i have done is in another color (red)
here is my code :
Sub Macro2()
'
' Macro2 Macro
'
'
i = Range("G3").Select
j = Range("D3").Select
With ActiveChart.ChartArea.Select
i.MarkerBackgroundColor = RGB(250, 250, 250)
j.MarkerForegroundColor = RGB(250, 250, 250)
End With
End Sub
In i is the X abscisse and j is the Y abscisse of the last point !
thank you for any advice
This code will set the last marker on the chart to red. Note the the RGB value for red is (255, 0, 0)
Sub SetLastMarkerRed()
Dim ws As Worksheet
Dim ch As Chart
Dim sc As SeriesCollection
Dim s As Series
Dim p As Point
Set ws = ThisWorkbook.ActiveSheet
Set ch = ws.ChartObjects(1).Chart
Set sc = ch.SeriesCollection
Set s = sc.Item(1)
Set p = s.Points(s.Points.Count)
p.MarkerBackgroundColor = RGB(255, 0, 0)
p.MarkerForegroundColor = RGB(255, 0, 0)
Set ws = Nothing
Set ch = Nothing
Set sc = Nothing
Set s = Nothing
Set p = Nothing
End Sub
Your code works but it does this :
I have an Excel file with a few charts and the attached dashboard (as can be seen in the image).
I am copying the charts objects from Excel to PowerPoint, but not sure what is the best way of copying the attached dashboard to PowerPoint, as it consists of a range of Excel cells, some Indicators using Conditional Formatting, and a circle object.
I don't want to copy it as a picture, because then it looks like it's out-of-focus in PowerPoint.
I have added a section of my code (not the whole thing as it's very long), just want to know the method of copying this dashboard image.
Public Sub UpdatePowerPoint(PowerPointFile)
'Add a reference to the Microsoft PowerPoint Library by:
'1. Go to Tools in the VBA menu
'2. Click on Reference
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay
Dim ppProgram As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim ppFullPath As String
Dim ppName As String
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim cht_count As Integer
Dim myShape As Object
Dim myChart As Object
Dim SlideNum, GPLRank As Integer
Dim ProjectIPPNum, ProjectName As String
Dim ShapeNum As Integer
Dim ExpenseActual, ExpenseBalance As Long
Dim StageStat As String
Dim nextKD As String
Dim shapeStageStat As Shape
On Error Resume Next
Set ppProgram = GetObject(, "PowerPoint.Application")
On Error GoTo 0
ppFullPath = PowerPointFile
If ppProgram Is Nothing Then
Set ppProgram = New PowerPoint.Application
i = 1
Else
If ppProgram.Presentations.Count > 0 Then
ppName = Mid(ppFullPath, InStrRev(ppFullPath, "\") + 1, Len(ppFullPath))
i = 1
ppCount = ppProgram.Presentations.Count
Do Until i = ppCount + 1
If ppProgram.Presentations.Item(i).Name = ppName Then
Set ppPres = ppProgram.Presentations.Item(i)
GoTo OnePager_Pres_Found
Else
i = i + 1
End If
Loop
End If
End If
ppProgram.Presentations.Open Filename:=PowerPointFile ' 'PowerPointFile = "C:\Test.pptx"
Set ppPres = ppProgram.Presentations.Item(i)
OnePager_Pres_Found:
ppPres.Windows(1).Activate ' activate the One-Pager Presentation in case you have several open, and the One_pager is currently not the app "on-focus"
' loop through all PowerPoint Slides, and copy all Chart objects from Excel
For ProjectCounter = 0 To NumberofProjectShts
Worksheets(ProjectShtName(ProjectCounter)).Activate
GPLRank = ActiveSheet.Cells(12, 2)
SlideNum = ActiveSheet.Cells(24, 2)
ProjectIPPNum = ActiveSheet.Cells(2, 2)
ProjectName = ActiveSheet.Cells(3, 2)
StageStat = ActiveSheet.Cells(20, 2)
nextKD = ActiveSheet.Cells(18, 2)
ExpenseActual = ActiveSheet.Cells(33, 4)
ExpenseBalance = ActiveSheet.Cells(33, 5)
On Error GoTo Error_PPTSlideNum_Handler
ppProgram.ActivePresentation.Slides(SlideNum).Select
Set myShape = ppProgram.ActivePresentation.Slides(SlideNum).Shapes
' --- loop throughout the Slide shapes and search for the Shape of type chart, then delete the old ones
For i = myShape.Count To 1 Step -1
If myShape.Item(i).HasChart Or myShape.Item(i).Type = msoEmbeddedOLEObject Or myShape.Item(i).Type = msoPicture Then
myShape.Item(i).Delete
Else
If myShape.Item(i).Left > 600 Then
myShape.Item(i).Delete
Else
Select Case myShape.Item(i).AutoShapeType
Case msoShapeOval, msoShapeOctagon, msoShapeIsoscelesTriangle
myShape.Item(i).Delete
End Select
End If
End If
Next
'Show the PowerPoint
ppProgram.Visible = True
' select the 1-Pager Slide number which we will update the charts with the Excel Charts
Set activeSlide = ppProgram.ActivePresentation.Slides(SlideNum)
' --- copy the dasboard (with Stage Status indicator) from Excel to Powerpoint , as Embedded Excel object ---
' this is the part I've added to copy the dashboard from Excel to PowerPoint slide
Columns("F:G").ColumnWidth = 7.71
Columns("H:J").ColumnWidth = 4.71
Rows("1:4").RowHeight = 18.75
ActiveSheet.Range("F1:J4").Copy ' .Select
' Paste to PowerPoint and position
Set myShape = ppProgram.ActivePresentation.Slides(SlideNum).Shapes.PasteSpecial(ppPasteMetafilePicture, msoFalse)
' Set Dashboard object properties:
myShape.Left = 536 ' 7.44"
myShape.Top = 7 ' 0.1"
' --- Loop through each chart in the Excel worksheet and paste them into the PowerPoint ---
For Each cht In ActiveSheet.ChartObjects
'go to the 1-Pager Slide number where we will update the charts with the Excel Charts
Set activeSlide = ppProgram.ActivePresentation.Slides(SlideNum)
'Copy the chart and paste it into the PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
If cht.Name = "RiskRadar_Chart" Then ' change paste setting only for Radar type chart, to look nicer in PowerPoint
Set myChart = ppProgram.ActivePresentation.Slides(SlideNum).Shapes.PasteSpecial(ppPasteMetafilePicture, msoFalse)
Else
Set myChart = ppProgram.ActivePresentation.Slides(SlideNum).Shapes.PasteSpecial(ppPasteDefault, msoFalse) 'ppPasteShape
End If
'Adjust the positioning of the Chart on Powerpoint Slide , each inch is 72 points
Select Case cht.Name
Case "Timeline_Chart" ' 1 ' Timeline Chart
myChart.Left = 11 ' 0.16"
myChart.Top = 403 ' 5.55"
Case "Budget_Chart" ' 2 ' Man-Hours Chart
myChart.Left = 387 ' 5.37"
myChart.Top = 284 ' 3.94"
Case "Expense_Chart" ' 3 ' Expense Chart
myChart.Left = 387 ' 5.37"
myChart.Top = 347 ' 4.81"
Case "RiskRadar_Chart" ' 4 ' Risk-Radar Chart
myChart.Left = 449 ' 6.23"
myChart.Top = 7 ' 0.1"
End Select
Next
' --- Add Stage Status indicator with Next KD text inside (except PARK) ----
Select Case StageStat
Case "Green"
With activeSlide.Shapes.AddShape(msoShapeOval, 652, 16, 32, 32) ' Left, Top , Width ,Height
.Fill.ForeColor.RGB = RGB(0, 128, 0) ' color Green
.Fill.Solid
.Line.ForeColor.ObjectThemeColor = msoThemeColorText1
.Line.Weight = 0.75
.TextFrame.TextRange.Font.color.RGB = RGB(0, 0, 0) ' Shape Text Color
.TextFrame.TextRange.Characters.Text = nextKD ' Text inside Shape
.TextFrame2.TextRange.Font.Size = 14 ' Adjust Font Size
.TextFrame2.TextRange.Font.Name = "Arial" ' Adjust Font Style
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter ' Center Align Text
.TextFrame2.VerticalAnchor = msoAnchorMiddle ' Vertically Align Text to Middle
.TextFrame2.MarginLeft = 0
.TextFrame2.MarginRight = 0
End With
Case "Yellow"
With activeSlide.Shapes.AddShape(msoShapeRectangle, 652, 16, 32, 32) ' Left, Top , Width ,Height
.Fill.ForeColor.RGB = RGB(255, 255, 0) ' color Yellow
.Fill.Solid
.Line.ForeColor.ObjectThemeColor = msoThemeColorText1
.Line.Weight = 0.75
.TextFrame.TextRange.Font.color.RGB = RGB(0, 0, 0) ' Shape Text Color
.TextFrame.TextRange.Characters.Text = nextKD ' Text inside Shape
.TextFrame2.TextRange.Font.Size = 14 ' Adjust Font Size
.TextFrame2.TextRange.Font.Name = "Arial" ' Adjust Font Style
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter ' Center Align Text
.TextFrame2.VerticalAnchor = msoAnchorMiddle ' Vertically Align Text to Middle
.TextFrame2.MarginLeft = 0
.TextFrame2.MarginRight = 0
End With
Case "Red"
With activeSlide.Shapes.AddShape(msoShapeIsoscelesTriangle, 652, 16, 36, 36) ' Left, Top , Width ,Height
.Fill.ForeColor.RGB = RGB(255, 0, 0) ' color Red
.Fill.Solid
.Line.ForeColor.ObjectThemeColor = msoThemeColorText1
.Line.Weight = 0.75
.TextFrame.TextRange.Font.color.RGB = RGB(0, 0, 0) ' Shape Text Color
.TextFrame.TextRange.Characters.Text = nextKD ' Text inside Shape
.TextFrame2.TextRange.Font.Size = 14 ' Adjust Font Size
.TextFrame2.TextRange.Font.Name = "Arial" ' Adjust Font Style
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter ' Center Align Text
.TextFrame2.VerticalAnchor = msoAnchorMiddle ' Vertically Align Text to Middle
.TextFrame2.MarginLeft = 0
.TextFrame2.MarginRight = 0
.TextFrame2.Column.Number = 2
End With
End Select
Error_PPTSlideNum_Handler:
If Err.Number <> 0 Then
Err.Clear
MsgBox "Project " & ProjectName & " Slide Number " & SlideNum & " not found in selected PowerPoint. " & _
vbCrLf & "Update your Slide Number according to it's position.", vbInformation, "PowerPoint Slide Number Error"
End If
Next ' ProjectCounter = 0 To NumberofProjectShts
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set ppProgram = Nothing
Set ppPres = Nothing
End Sub
You can try with the sample example shown here. Lot of effort goes to properly naming the ranges for various parameters which is done in Excel worksheet. I have also shown a snapshot of the name manager to give you an idea and also the snapshot of final output of the dashboard in the PowerPoint.
Option Explicit
Dim PP As Object
Dim PP_File As Object
Dim PP_Slide As Object
Private Sub CopyandPastetoPPT(myRangeName As String, myTitle As String, myScaleHeight As Single, myScaleWidth As Single)
Dim NextShape As Integer
Dim ReportDate As String
ReportDate = Range("myReportDate").Value & " / Week " & Range("myReportWeek").Value & " - "
Application.GoTo Reference:=myRangeName
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Range("A1").Select
PP.ActivePresentation.Slides.Add PP.ActivePresentation.Slides.Count + 1, 11
Set PP_Slide = PP_File.Slides(PP.ActivePresentation.Slides.Count)
PP_Slide.Shapes.Title.TextFrame.TextRange.Text = ReportDate & myTitle
NextShape = PP_Slide.Shapes.Count + 1
PP_Slide.Shapes.PasteSpecial 2
PP_Slide.Shapes(NextShape).ScaleHeight myScaleHeight, 1
PP_Slide.Shapes(NextShape).ScaleWidth myScaleWidth, 1
PP_Slide.Shapes(NextShape).Left = PP_File.PageSetup.SlideWidth \ 2 - PP_Slide.Shapes(NextShape).Width \ 2
PP_Slide.Shapes(NextShape).Top = 90
End Sub
Sub ExportToPPT()
Dim ActFileName As Variant
Dim ScaleFactor As Single
On Error GoTo ErrorHandling
ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt), *.ppt")
ScaleFactor = Range("myScaleFactor").Value
Set PP = CreateObject("Powerpoint.Application")
If ActFileName = False Then
PP.Activate
PP.Presentations.Add
Set PP_File = PP.ActivePresentation
Else
PP.Activate
Set PP_File = PP.Presentations.Open(ActFileName)
End If
PP.Visible = True
CopyandPastetoPPT "myDashboard01", Range("myInputStartTitles").Offset(1, 0).Value, ScaleFactor, ScaleFactor
Set PP_Slide = Nothing
Set PP_File = Nothing
Set PP = Nothing
Worksheets(1).Activate
Exit Sub
ErrorHandling:
Set PP_Slide = Nothing
Set PP_File = Nothing
Set PP = Nothing
MsgBox "Error No.: " & Err.Number & vbNewLine & vbNewLine & "Description: " & Err.Description, vbCritical, "Error"
End Sub
So i have been struggling with this for the past few days, i have this powerpoint 2007 presentation that i fill with information from a button in a from in a access file using VBA.
And in the first slide (and only by now) i have a table that will receive part of the information, however i can't make the table content break to another slide if the table exceeds the bottom of the slide, it just goes out of range.
I have the method to create a the new slide, and that works fine. But i can't seem to find an example that could get me started.
I think i should be something like check the table bottom exceeds slide bottom if it does create a new slide, cut the overlap cells and paste them in the new slide?
Thanks in Advance.
The code example:
' Open PowerPoint
Dim pptobj As PowerPoint.Application
Dim Presentation As PowerPoint.Presentation
Dim oSl as Slide
Set pptobj = New PowerPoint.Application
Set pptobj = CreateObject("Powerpoint.Application")
pptobj.Activate
Set Presentation = pptobj.Presentations.Open("C:\Users\some.pptx")
pptobj.Visible = True
pptobj.WindowState = ppWindowMaximized
If ((Len(Forms!Some!Name> 0) Then
pptobj.ActivePresentation.Slides(1).Shapes("TableNome").Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!Name))
End If
Set oSl = pptobj.ActivePresentation.Slides(1)
With oSl
.Shapes("TableCategory").Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = (CStr(Forms!CVLong!TxtCategory))
.Shapes("TableEmail").Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!TxtEmail))
.Shapes("TableData").Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!TxtTlf))
.Shapes("TableData").Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!TxtCell))
End With
Dim oSh as Shape
Dim overhang
Set oSh = pptobj.ActivePresentation.Slides(1).Shapes.AddTable(1, 3, 50, 100, 493)
'One
If ((Len(Forms!Some!One)) > 0) Then
pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(1, 3).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!One)) & vbNewLine & vbNewLine
pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(1, 1).Shape.TextFrame.TextRange.Text = "One"
End If
'Two
If (Len(Forms!Some!Two> 0) Then
pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(5, 3).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!Two)) & vbNewLine
pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(5, 1).Shape.TextFrame.TextRange.Text = "Two"
End If
'Three
If (Len(Forms!Some!Three) > 0) Then
pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(4, 3).Shape.TextFrame.TextRange.Text = (CStr(Forms!Some!Three)) & vbNewLine & vbNewLine
pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(4, 1).Shape.TextFrame.TextRange.Text = "Three"
End If
'Add Slide
Dim Sld As Slide
Dim x As Integer
x = 1
Set Sld = pptobj.ActivePresentation.Slides.Add(Index:=pptobj.ActivePresentation.Slides.Count + 1, Layout:=ppLayoutBlank)
For Each Sld In pptobj.ActivePresentation.Slides
If x >= 2 Then
pptobj.ActivePresentation.Slides(1).Shapes("Text Placeholder 15").Copy
pptobj.ActivePresentation.Slides(x).Shapes.Paste
pptobj.ActivePresentation.Slides(x).Shapes("Text Placeholder 15").ZOrder msoSendToBack
pptobj.ActivePresentation.Slides(x).Shapes("Text Placeholder 15").Height = 810
pptobj.ActivePresentation.Slides(x).Shapes("Text Placeholder 15").Top = 19
End If
x = x + 1
Next
End If
'Put table top border
Dim n As Integer
Dim r As Integer
n = 3
r = 1
While r <= n
If Len(pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(r, 3).Shape.TextFrame.TextRange.Text) > 0 Then
pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(r, 3).Borders(ppBorderTop).Visible = msoTrue
pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Cell(r, 3).Borders(ppBorderTop).ForeColor.RGB = RGB(220, 105, 0)
Else
pptobj.ActivePresentation.Slides(1).Shapes("TableInfo").Table.Rows(r).Delete
n = n - 1
r = r - 1
End If
r = r + 1
Wend
'Add Photo
pptobj.ActivePresentation.Slides(1).Shapes.AddPicture(FileName:="\\someplace\" & [Id] & ".jpg", linktofile:=mostrue, savewithdocument:=msoTrue, Left:=52, Top:=115).Select
With pptobj.ActivePresentation.Slides(1).Shapes("Picture 7")
.LockAspectRatio = msoTrue
.Width = 85
.Left = 38
.Top = 80
End With
'add footer
Dim page As Integer
page = 1
Dim s As Slide
For Each s In pptobj.ActivePresentation.Slides
On Error Resume Next
Set oSh = s.HeadersFooters.Footer
If Err.Number <> 0 Then
Call s.Master.Shapes.AddPlaceholder(ppPlaceholderFooter, 219, 805, 342, 19)
End If
On Error GoTo 0
s.HeadersFooters.Footer.Visible = msoTrue
s.HeadersFooters.Footer.Text = (CStr(Forms!Some!Name)) & " - Page " & page & " of " & pptobj.ActivePresentation.Slides.Count
page = page + 1
Next
The following code snippet may give you some inspiration. Right now it just determines that the table is too large and gives you a message. Without more information about the type of data and how you obtained it, it's hard to give an answer to the second part of the problem. Most likely you would create a table, add one row at a time and check the size of the table; when the table gets too large (or within a certain distance from the bottom) you create a new slide and continue the process. That is probably better than creating a table that's too large, then trying to figure out where to cut it.
Here is the code:
Sub createTable()
Dim oSl As Slide
Dim oSh As Shape
Dim overhang
Set oSl = ActivePresentation.Slides(1)
Set oSh = oSl.Shapes.AddTable(28, 3)
overhang = ActivePresentation.PageSetup.SlideHeight - (oSh.Height + oSh.Top)
If overhang > 0 Then
MsgBox "the table fits"
Else
MsgBox "the table is too big!"
End If
End Sub
I have created this code to replace one accent colors of the template with another (ObjectThemeColors), the Brightness (tint and shade) element is over-ruled and all shades of the old accent colors are replaced with the same shade as that of the given new color, can anybody help to preserve the brightness/shades while changing to new accent colors?
Sub ReplaceColorNew(OldColor As String, NewColor As String)
Dim oeff As Effect
Dim i As Integer
Dim t As Integer
Dim oSld As Slide
Dim oShp As Shape
Dim x, y As Integer
Dim oPP As Placeholders
For Each oSld In ActivePresentation.Slides
For Each oShp In oSld.Shapes
'groups
If oShp.Type = msoGroup Then
For x = 1 To oShp.GroupItems.Count
With oShp.GroupItems(x)
If .Fill.ForeColor.ObjectThemeColor = Conversion.CLng(OldColor) + 5 Then
.Fill.ForeColor.ObjectThemeColor = Conversion.CLng(NewColor) + 5
End If
If .Line.Visible Then
If .Line.ForeColor.ObjectThemeColor = Conversion.CLng(OldColor) + 5 Then
.Line.ForeColor.ObjectThemeColor = Conversion.CLng(NewColor) + 5
End If
End If
If .HasTextFrame Then
If .TextFrame.HasText Then
For y = 1 To .TextFrame.TextRange.Runs.Count
If .TextFrame.TextRange.Runs(y).Font.Color.ObjectThemeColor = Conversion.CLng(OldColor) + 5 Then
.TextFrame.TextRange.Runs(y).Font.Color.ObjectThemeColor = Conversion.CLng(NewColor) + 5
End If
Next
End If
End If
End With
Next
Else
With oShp 'other shapes
' Fill
If .Fill.ForeColor.ObjectThemeColor = Conversion.CLng(OldColor) + 5 Then
.Fill.ForeColor.ObjectThemeColor = Conversion.CLng(NewColor) + 5
End If
' Line
If Not .Type = msoTable Then
If .Line.Visible = msoTrue Then
If .Line.ForeColor.ObjectThemeColor = Conversion.CLng(OldColor) + 5 Then
.Line.ForeColor.ObjectThemeColor = Conversion.CLng(NewColor) + 5
End If
End If
End If
' Text
If .HasTextFrame Then
If .TextFrame.HasText Then
For y = 1 To .TextFrame.TextRange.Runs.Count
If .TextFrame.TextRange.Runs(y).Font.Color.ObjectThemeColor = Conversion.CLng(OldColor) + 5 Then
.TextFrame.TextRange.Runs(y).Font.Color.ObjectThemeColor = Conversion.CLng(NewColor) + 5
End If
Next
End If
End If
End With
End If
'oShp = Nothing
Next oShp
Next oSld
End Sub
Before changing the ObjectThemeColor, pick up the current TintAndShade and brightness, then apply them again after changing the ObjectThemeColor. Simplified example:
With oSh.Fill.ForeColor
lThemeColor = .ObjectThemeColor
sBrightness = .Brightness
sTintShade = .TintAndShade
.ObjectThemeColor = lThemeColor + 1
.Brightness = sBrightness
.TintAndShade = sTintShade
End With
Actually, I think preserving Brightness alone might be sufficient; give it a try and let us know.