Excel to PowerPoint VBA - Need help diagnosing and fixing error in code

[onthegreen03]

Hi - I worked with a VBA expert @Worf on this board several years ago and eventually came up with the code below which auto copied charts/graphs from multiple Excel tabs to PowerPoint. It was a little messy but it worked perfectly. I am now trying to copy that same code into a new file but when I try running it stops on the line highlighted below. It worked a few years ago in a different file but now does not work. Can someone help me figure out how to get this moving again?

Sub RunAllMacros()
'
Procedure1
Procedure2
MsgBox "Success!", 64
End Sub

Sub Procedure1()
'
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
objppt.Presentations.Open "C:\USERS\me\Blank.potx" ' your path here
End Sub

Sub Procedure2()
'
tsl = 1 ' title and subtitle layout
bl = 7 ' background layout for presentation body
la = Array(70, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10) ' left
ta = Array(90, 105, 105, 105, 105, 105, 105, 105, 105, 105, 105) ' top
sar = Array("(7)", "(8)", "(9)", "(10)", "(11)", "(12)", "(14)", "(15)", "(16)", "(17)", "(18)")
rad = Array("B2:T49", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56", "A15:Ac56") ' ranges
wa = Array(0.8, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98, 0.98) ' percentages of slide width and height
ha = Array(0.75, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7)
Set mypres = objppt.ActivePresentation
Do While mypres.Slides.Count > 1
mypres.Slides(mypres.Slides.Count).Delete
Loop
Set sl = objppt.ActiveWindow.View.Slide
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl)
For i = LBound(sar) To UBound(sar)
FormatSlide (i + 1)
Set Rng = ThisWorkbook.Sheets(sar(i)).Range(rad(i))
Rng.Copy
sl.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
Set shp = sl.Shapes(sl.Shapes.Count)
With shp
.Name = "sheetrange"
.LockAspectRatio = 0
.Left = la(i)
.Top = ta(i)
.Width = wa(i) * mypres.PageSetup.SlideWidth ' set picture size
.Height = ha(i) * mypres.PageSetup.SlideHeight
End With
Set sl = mypres.Slides.Add(mypres.Slides.Count + 1, ppLayoutTitle) ' title and subtitle
Next
If mypres.Slides.Count > 3 Then mypres.Slides(mypres.Slides.Count).Delete
Set sl = mypres.Slides.Add(1, ppLayoutTitleOnly)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(tsl) ' desired cover background
sl.Shapes(1).TextFrame.TextRange.Text = "US HEM/ONC Franchise Performance Update"
sl.Shapes(2).TextFrame.TextRange.Text = DateTime.Date
sl.Shapes(3).Delete ' slide number
objppt.Visible = 1: objppt.Activate
Application.CutCopyMode = False
End Sub

Sub FormatSlide(sn)
Set sl = mypres.Slides(sn)
Do While sl.Shapes.Count > 2
sl.Shapes(sl.Shapes.Count).Delete
Loop
sl.Shapes(1).Name = "_title"
sl.Shapes(2).Name = "sub_title"
sl.Shapes(1).TextFrame.TextRange.Text = Sheets("Titles").[a1].Offset(sn - 1)
sl.Shapes(1).TextFrame.VerticalAnchor = msoAnchorTop
sl.Shapes(2).TextFrame.TextRange.Text = Sheets("Titles").[b1].Offset(sn - 1)
sl.CustomLayout = mypres.Designs(1).SlideMaster.CustomLayouts(bl)
With sl.Shapes(1)
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
.Top = 7
.Left = 10
.Width = mypres.PageSetup.SlideWidth * 0.98
.TextFrame.TextRange.Font.Size = 22
.TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
.TextFrame.TextRange.Font.Bold = 1
End With
With sl.Shapes(2)
.Top = sl.Shapes(1).Top + sl.Shapes(1).Height - 30 ' position subtitle
.Left = 10
.TextFrame.TextRange.Font.Color.RGB = RGB(250, 250, 250)
.TextFrame.TextRange.Font.Italic = msoTrue
.TextFrame.TextRange.ParagraphFormat.Bullet = msoFalse
.Width = mypres.PageSetup.SlideWidth * 0.98
.TextFrame.TextRange.Font.Size = 20
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignRight
End With
sl.Shapes.AddShape msoShapeRectangle, 50, 50, 20, 15
With sl.Shapes(3)
.Top = mypres.PageSetup.SlideHeight - 20
.Left = 10
.TextFrame.TextRange.Font.Color.RGB = RGB(1, 2, 3)
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(250, 250, 250)
.TextFrame.TextRange.InsertSlideNumber
.TextFrame.TextRange.Font.Size = 8
.TextFrame.TextRange.Font.Italic = msoTrue
End With
End Sub

 

[onthegreen03]

Worf, you are amazing. Worked like a charm with no errors or formatting issues. Thank you again for working on this, I hope others find it as useful as I do. For those who are looking to use the final working code you just need to add a tab in your Excel file called "Titles". In cell A1 (going down) you would put in whatever title you want on each body slide, and in B1 (going down) you would add in any subtitle message. The code will pick those up and place them at the top of the slide.

 

[onthegreen03]

Worf, quick question. The code is working perfectly except the file size is HUGE when it's done. I did a bit of research and found out that I need to compress the pictures by following the steps below. When I do this the file size shrinks to normal and I am able to save and email. Is there a way to add this to the code so it compressing the file to "default resolution" when it's first pasted? If not, no worries I will just manually do that once the PP is set up. Thanks.

 

[Worf]

I am going offline now, but it may be necessary to tinker with the Registry: