vbanovice123
Board Regular
- Joined
- Apr 15, 2011
- Messages
- 91
Hi,
Urgently need help on the above, have been struggling for past two to three days with no solution.
Is there a way to reference a slide by the name instead of slide number? What function can I use?
specifically on this piece of the code. I tried declaring a string variable for slidename but was unable to figure out a way to locate the powerpoint slide by title.
I also gave a title to the slide in power point. Is there a workable solution?
' 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:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select
Currently using the below
Sub RangeToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.slide
' 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
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
' Copy the range as a piicture
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select
' Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
MsgBox "Copied cells " & Selection.Address
End Sub
'Public Function copy_range(sheet, rowStart, columnStart, row_count, columnCount, slide, aheight, awidth, atop, aleft)
'Public Function copy_range(sheet, rngname, slide, aheight, awidth, atop, aleft, vscale)
Public Function copy_range(sheet, rngname, slide, arheight, arwidth, artop, arleft, vscale)
Sheets(sheet).Select
'Cells(rowStart, columnStart).Resize(row_count, columnCount).Select
Range(rngname).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:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select
Set sr = PPApp.ActiveWindow.Selection.ShapeRange
sr.LockAspectRatio = msoFalse
' Resize:
sr.Width = arwidth
sr.Height = arheight
sr.Top = artop
sr.Left = arleft
'sr.ScaleHeight 0.9, msoFalse
sr.ScaleWidth vscale, msoFalse
'If sr.Width > 700 Then
'sr.Width = 700
'If sr.Width > 520 Then
'sr.Width = 520
'Else: sr.Width = 511
If sr.Width > 300 Then
sr.Width = 300
Else: sr.Width = 625
End If
'If sr.Height > 420 Then
'sr.Height = 420
If sr.Height > 430 Then
sr.Height = 430
Else: sr.Height = 425
End If
' Realign:
sr.Align msoAlignCenters, True
sr.Align msoAlignMiddles, True
'sr.Top = atop
If sr.Top > 90 Then
sr.Top = 90
Else
sr.Top = 80
End If
'If aleft <> 0 Then
If aleft > 60 Then
sr.Left = 60
Else
sr.Left = 50
End If
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Function
Urgently need help on the above, have been struggling for past two to three days with no solution.
Is there a way to reference a slide by the name instead of slide number? What function can I use?
specifically on this piece of the code. I tried declaring a string variable for slidename but was unable to figure out a way to locate the powerpoint slide by title.
I also gave a title to the slide in power point. Is there a workable solution?
' 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:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select
Currently using the below
Sub RangeToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.slide
' 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
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
' Copy the range as a piicture
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select
' Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
MsgBox "Copied cells " & Selection.Address
End Sub
'Public Function copy_range(sheet, rowStart, columnStart, row_count, columnCount, slide, aheight, awidth, atop, aleft)
'Public Function copy_range(sheet, rngname, slide, aheight, awidth, atop, aleft, vscale)
Public Function copy_range(sheet, rngname, slide, arheight, arwidth, artop, arleft, vscale)
Sheets(sheet).Select
'Cells(rowStart, columnStart).Resize(row_count, columnCount).Select
Range(rngname).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:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select
Set sr = PPApp.ActiveWindow.Selection.ShapeRange
sr.LockAspectRatio = msoFalse
' Resize:
sr.Width = arwidth
sr.Height = arheight
sr.Top = artop
sr.Left = arleft
'sr.ScaleHeight 0.9, msoFalse
sr.ScaleWidth vscale, msoFalse
'If sr.Width > 700 Then
'sr.Width = 700
'If sr.Width > 520 Then
'sr.Width = 520
'Else: sr.Width = 511
If sr.Width > 300 Then
sr.Width = 300
Else: sr.Width = 625
End If
'If sr.Height > 420 Then
'sr.Height = 420
If sr.Height > 430 Then
sr.Height = 430
Else: sr.Height = 425
End If
' Realign:
sr.Align msoAlignCenters, True
sr.Align msoAlignMiddles, True
'sr.Top = atop
If sr.Top > 90 Then
sr.Top = 90
Else
sr.Top = 80
End If
'If aleft <> 0 Then
If aleft > 60 Then
sr.Left = 60
Else
sr.Left = 50
End If
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End If
End Function