Selected Excel Range to Power Point Kinda...

[BusDriver2]

Hi,

I cannot seem to figure this out for the life of me but I am hoping that someone in the forum may be able to help me.

I need to be able to send my selected range of cells (to include: the spreadsheet background, colored cells and all values contained) to Power Point for a daily product.

I found this great VBA online and would like to use it but the problem is I keep getting funny results. It doesn't matter what cells I select I keep getting a extra margin on the left side and top of the pasted product in power point. I then have to crop the results... I have looked at the macro (from my noodie eyes) and cannot seem to find a way to adjust this added on margin.

Does anybody know how I can fix this so that I do not have to crop the results in Power Point every time I use this macro?

Sub RangeToPresentation()
' Set a VBE reference to Microsoft PowerPoint Object Library
'Original code sourced from Jon Peltier http://peltiertech.com/Excel/XL_PPT.html

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

End Sub

NOTE: Select any range of cells, Selection is sent to Power Point, Power Point must be active. Due to Excel File size (tiled jpeg background) I was not able to post spreadsheet. But results are attached.

Any help with this would be really great.

Best Regards,

BusDriver2


Please see attached files.

[Leith Ross]

Hello BusDriver2,

Change the code to paste the image from...

     ' Align the pasted range
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

To this...

    ' Align the pasted range
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, True
    PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignLefts, True

Sincerely,
Leith Ross

[BusDriver2]

Hi Leith,

Thanks for the speedy response to my post.

I tried making the suggested changes to the VBA code but I am still having mixed results. I tried a bunch of different combination's and none seem to work.

The first result (see attached file 1) is using the suggested change, it doesn't matter what I select I always get this as a result.

The second result is (see attached file 2) when I tried to make a bigger selection and I get really strange results.

Any help or thoughts on this would be would be great. Thanks.


Best Regards,

BusDriver2

Please see attached.

[Leith Ross]

Hello BusDriver2,

I felt certain the code change would work. Since the picture is being tiled on the slide background no matter what alignment is used, there must be some other setting that needs to changed. I will do some more code testing and hopefully have an answer for you.

Sincerely,
Leith Ross

[BusDriver2]

Leith,

Thanks for your help on this, I will check back again.

Best Regards,

BusDriver2

[BusDriver2]

Hi Leith,

I haven't heard back from you on the last post so I searched the internet and found a few macros that I was able to sew together and then make it work for my needs. Part of it the macro was authored by A. Pope and the other part was authored by Mr. Peltier.

This is the procedure that worked for me, Copy and paste the first macro in to Excel.

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
 
Private Const KEYEVENTF_KEYUP = &H2
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12

Sub FrankenMacro()
' Do not forget to set a VBE reference to Microsoft PowerPoint Object Library
' This Macro is to be installed in EXCEL

Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
    
    keybd_event VK_SNAPSHOT, 1, 0, 0
    DoEvents
    Set PPApp = GetObject(, "Powerpoint.Application")
    Set PPPres = PPApp.ActivePresentation
    
    PPApp.ActiveWindow.ViewType = ppViewSlide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    PPSlide.Shapes.Paste.Select
    Set PPSlide = Nothing
    
    Set PPPres = Nothing
    Set PPApp = Nothing

End Sub

Then launch Power Point and copy and paste this macro in to Power Point.

Sub ResizeFrankenMacro()

' This macro has to be installed in POWER POINT
' Remeber to change the security settings allowing macros to "Play"
' On the Toolbar, Right Click, Customize, scroll down, Macros, Drag UP to your toolbar

    ActiveWindow.Selection.ShapeRange.PictureFormat.CropLeft = 71.99
    ActiveWindow.Selection.ShapeRange.PictureFormat.CropRight = 239.98
    With ActiveWindow.Selection.ShapeRange
        .IncrementLeft 18#
        .IncrementTop 44.25
    End With
    ActiveWindow.Selection.ShapeRange.PictureFormat.CropTop = 83.99
    With ActiveWindow.Selection.ShapeRange
        .IncrementLeft 30#
        .IncrementTop -192#
    End With
    ActiveWindow.Selection.ShapeRange.PictureFormat.CropBottom = 70.49
    With ActiveWindow.Selection.ShapeRange
        .IncrementLeft -36#
        .IncrementTop 126#
    End With
    With ActiveWindow.Selection.ShapeRange
        .ScaleWidth 1.1, msoFalse, msoScaleFromTopLeft
        .ScaleHeight 1.1, msoFalse, msoScaleFromTopLeft
    End With
    ActiveWindow.Selection.Unselect
End Sub

Once these macros are installed... both Excel and Power Point must be active/open... from Excel execute the macro, it will take a Screen Capture of the active window and paste it in to Power Point... from Power Point execute that macro and it should trim/crop it to the size of the slide.

Best Regards,

This forum is the BEST... BusDriver2