Mnewton911
New member
- Local time
- Today, 01:05
- Joined
- Sep 14, 2010
- Messages
- 8
I am building a macro to write a bunch of information to powerpoint slides an attempt to automate the process.
I borrowed some code from a friend's application which simply posted pictures of text ranges.
I was wondering if this formula could be altered given the format of the selection to instead of pasting the excel range as an image - but a linked table so that i do not have to re-run the whole macro each time we need to make a formatting change.
Here is the code as listed below.
Any help into this would be amazing.
Thank You!
- Matt
I borrowed some code from a friend's application which simply posted pictures of text ranges.
I was wondering if this formula could be altered given the format of the selection to instead of pasting the excel range as an image - but a linked table so that i do not have to re-run the whole macro each time we need to make a formatting change.
Here is the code as listed below.
Code:
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 = 700
End If
If sr.Height > 420 Then
sr.Height = 420
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
Thank You!
- Matt
Last edited by a moderator: