Some help with vba code copy paste to Powerpoint

Hi,

We have the below macro Public_Functions and a main macro called makePowerPoint() which is pasted at the end.

We have the following issues that we need help in resolving.

1. get the correct width, it is still narrow no matter what I do. I might be missing a critical option.
2. Delete just the chart or worksheet in the slide andnot the entire slide with text etc.

Additionally, I do not understand why the below is pasting the chart HFIChart1 in both slide 2 and slide 3. The below code is in the main module.

copy_chart "sheet1", "HFIChart1", 3, 884, 378, 106.5, 47

copy_chart "sheet2", "HFIChart2", 2, 884, 378, 106.5, 47


The Public_Functions has the multiple sheets to copy declared as in an array.

Sheets(Array("HFIChart1", "HFIChart2")).Select

Thanks for your help. Appreciate it.

Regards,
macroppt123








[FONT='Arial','sans-serif']Public Function copy_chart(sheet, chart_name, slide, awidth, aheight, atop, aleft)

Sheets(Array("HFIChart2", "HFIChart1")).Select


' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.slide
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
PPApp.ActiveWindow.View.GotoSlide (slide)
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

'ActiveSheet.ChartObjects(chart_name).Activate
ActiveChart.ChartArea.Copy
PPSlide.Select
'If PPSlide.Shapes.Count > 0 Then
'PPSlide.Shapes.Range.Delete
'Else
PPSlide.Shapes.PasteSpecial ppPastePNG
PPSlide.Select
PPSlide.Shapes(PPSlide.Shapes.Count).Select
Dim sr As PowerPoint.ShapeRange
Set sr = PPApp.ActiveWindow.Selection.ShapeRange
' Resize:
sr.Width = awidth
sr.Height = aheight
If sr.Width > 519 Then
sr.Width = 884
End If
If sr.Height > 420 Then
sr.Height = 525
End If

' Realign:
sr.Align msoAlignCenters, True
sr.Align msoAlignMiddles, True
sr.Top = atop
If aleft <> 0 Then
sr.Left = aleft
End If
'End If

Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Function


Public Function copy_range(sheet, rowStart, columnStart, row_count, columnCount, slide, aheight, awidth, atop, aleft)

Sheets(sheet).Select
Cells(rowStart, columnStart).Resize(row_count, columnCount).Select
' Make sure a range is selected
If Not TypeName(Selection) = "Range" Then
MsgBox "Please select a worksheet range and try again.", vbExclamation, _
"No Range Selected"
Else
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
PPApp.ActiveWindow.View.GotoSlide (slide)
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
' Copy the range as a picture
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
' Paste the range
PPSlide.Shapes.Paste.Select
Dim sr As PowerPoint.ShapeRange
Set sr = PPApp.ActiveWindow.Selection.ShapeRange
' Resize:
sr.Width = awidth
sr.Height = aheight
If sr.Width > 700 Then
sr.Width = 884
End If
If sr.Height > 420 Then
sr.Height = 525
End If
' Realign:
sr.Align msoAlignCenters, True
sr.Align msoAlignMiddles, True
sr.Top = atop
If aleft <> 0 Then
sr.Left = aleft
End If

' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Function


Public Function copy_text(sheet, rowStart, columnStart, row_count, columnCount, slide, textbox)
Sheets(sheet).Select
Text = Cells(rowStart, columnStart).Resize(row_count, columnCount).Text
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = ppViewSlide
PPApp.ActiveWindow.View.GotoSlide (slide)
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
PPSlide.Shapes(textbox).TextFrame.TextRange = Text
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Function



'Public Function add_slide()

' Reference existing instance of PowerPoint
'Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
'Set PPPres = PPApp.ActivePresentation
'create new slide
'PPApp.Activate
'PPPres.Slides.AddSlide PPPres.Slides.Count + 1, PPPres.SlideMaster.CustomLayouts(2)
'End Function







Sub makePowerPoint()
Dim PPT As PowerPoint.Application
Set PPT = New PowerPoint.Application
PPT.Visible = True
'PPT.Presentations.Open Filename:="C:\Desktop\New.pptx"


'' Title Slide ''
'copy_text "sheet1", 12, 2, 1, 1, 1, 1
'copy_text "sheet1", 13, 2, 1, 1, 1, 2
'copy_text "sheet1", 18, 2, 1, 1, 1, 3
'add_slide
'' Slide 2 ''
'copy_text "sheet2", 5, 2, 1, 1, 2, 1

'' Slide 3 ''
copy_chart "sheet1", "HFIChart1", 3, 884, 378, 106.5, 47

copy_chart "sheet2", "HFIChart2", 2, 884, 378, 106.5, 47


'copy_chart "sheet2", "Chart 4", 2, 250, 200, 60, 360
'copy_chart "sheet2", "Chart 1", 2, 250, 200, 300, 15
'copy_chart "sheet2", "Chart 2", 2, 250, 200, 300, 360
'add_slide

End Sub

[/FONT]