I have some code I found on Jon Peltier's website that I modified a bit for my purposes. I am actually developing it into an addin. I have a question about some of the control Excel may have when putting a picture from Excel into Power Point...

I can transfer the picture easy enough, but after the transfer I cannot figure out how to control the picture size or position. Also it takes the presenation out of the Normal View (which the user has to reselect every time this operation is performed (ie - Toolbar "View" --- "Normal").

Any help to better control this type of picture transfer is greatly appreciated. See my code below...


--------------------------------------------------------------------------------

Sub Cells2PPT_Pic()
On Error GoTo failed

Dim PPApp As Object
Dim PPPres As Object
Dim PPSlide As Object

ActiveWindow.DisplayGridlines = False

' 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.ViewType = 1
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRa nge.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

ActiveWindow.DisplayGridlines = True

failed:
If Err.Number = 429 Then
MsgBox "Please open your presentation first.", vbExclamation, _
"No Presentation Open"
ActiveWindow.DisplayGridlines = True
Exit Sub
End If

End Sub

--------------------------------------------------------------------------------

Take a look at the following properties for SHAPE
..top, .left, .width and .height



"Mark Ivey" wrote:

I have some code I found on Jon Peltier's website that I modified a bit for my purposes. I am actually developing it into an addin. I have a question about some of the control Excel may have when putting a picture from Excel into Power Point...

I can transfer the picture easy enough, but after the transfer I cannot figure out how to control the picture size or position. Also it takes the presenation out of the Normal View (which the user has to reselect every time this operation is performed (ie - Toolbar "View" --- "Normal").

Any help to better control this type of picture transfer is greatly appreciated. See my code below...


--------------------------------------------------------------------------------

Sub Cells2PPT_Pic()
On Error GoTo failed

Dim PPApp As Object
Dim PPPres As Object
Dim PPSlide As Object

ActiveWindow.DisplayGridlines = False

' 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.ViewType = 1
' Reference active slide
Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRa nge.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

ActiveWindow.DisplayGridlines = True

failed:
If Err.Number = 429 Then
MsgBox "Please open your presentation first.", vbExclamation, _
"No Presentation Open"
ActiveWindow.DisplayGridlines = True
Exit Sub
End If

End Sub

--------------------------------------------------------------------------------