Solved

Excel Printout to PPT Adjustment

Posted on 2015-01-08
11
153 Views
Last Modified: 2015-01-09
I have this great EE written Macro  (by Dmille, Phillip Burton, JSRWilson) that takes images from excel, based on range names and then places them on separate sheets in a PPT.  Here's my question.  Is there one or two lines of code that when the image is placed into PPT, it will auto adjust to center it and size it based on the size of the range?  It may be a "tweek" to several lines that Dave originally put into the routine.   Right now, it sends it over but then you have to align each slide and the image.

Here is the code;
Sub ChartToPPT_vDLMILLE()
 Const l_ppPasteEnhancedMetafile = 2
 Const ppLayoutBlank = 12

 'The "..._v3" version of the code copies pictures from excel whereas the "..._v2" version copies chart objects.
 'NO LONGER NEED TO "Set a VBE reference to Microsoft PowerPoint Object Library"
 'RB: changed to late binding by changing the powerpoint related declarations to "as object"  (& declaring constants too) to prevent the need for setting a Reference (ie the previous line is no longer necessary).
 Const ppViewNormal As Long = 9
 Const ppLayoutText As Long = 2
 Dim PPApp As Object 'PowerPoint.Application
 Dim PPPres As Object 'PowerPoint.Presentation
 Dim PPSlide As Object 'PowerPoint.Slide
 Dim PresentationFileName As String
 Dim SlideCount As Long
 Dim iCht As Long
 Dim sTitle As String
 Dim rImages As Range
 Dim rImage As Range
 Dim myPaste As Object
 Dim wkb As Workbook
 Dim wks As Worksheet
 Dim chkObj As Object

     Set wkb = ThisWorkbook


     'check for an existing instance of PowerPoint & if one doesn't exist then open one.
     On Error Resume Next
     Set PPApp = GetObject(, "Powerpoint.Application")
     On Error GoTo 0
     If PPApp Is Nothing Then
         Set PPApp = CreateObject("Powerpoint.Application")
         PPApp.Visible = msoTrue
     End If

     'DLM:  Check to see if any presentations exist.  Use the existing active presentation if so, or add one if no
     If PPApp.Presentations.Count = 0 Then
         Set PPPres = PPApp.Presentations.Add(msoTrue)
     Else
         Set PPPres = PPApp.ActivePresentation
     End If

     Set rImages = wkb.Names("OutputPPTRanges").RefersToRange
     
     For Each rImage In rImages
     
         'find range or image/chart
         On Error Resume Next
         Set chkObj = wkb.Names(rImage.Value).RefersToRange
         If Err.Number <> 0 Then
             Err.Clear
             For Each wks In wkb.Worksheets
                 Set chkObj = wks.Shapes(rImage.Value)
                 If Err.Number = 0 Then
                     Exit For
                 End If
                 Err.Clear
             Next wks
         End If
         
         chkObj.Copy
         
         If rImage.Value <> vbNullString And Err.Number = 0 Then 'found a valid range from the range name
             
             ' Add a new slide and paste in the chart
             With PPPres.Slides
                 SlideCount = .Count
                 Set PPSlide = .Add(SlideCount + 1, ppLayoutBlank)
             End With
     
             ''RB: "activewindow" removed (can be deleted) in case you move the ".visible = true" to the end of the macro
             'PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex

             With PPSlide
                 '' paste and select the chart picture
                 '.Shapes.Paste.Select
                 'RB: where possible avoid using ".select" as it slows code down, therefore I have changed the above to the below...
                Set myPaste = .Shapes.PasteSpecial(l_ppPasteEnhancedMetafile)
                
                 With myPaste
                     
                     ' Align the pasted range
                     .Align msoAlignCenters, True
                     .Align msoAlignMiddles, True
     
                     ' Position pasted chart
                     .Width = PPPres.PageSetup.SlideWidth - 20
                     .Left = 100
                     .Top = 160
                 End With
     
                 With .Shapes.Placeholders(1)
                     .TextFrame.TextRange.Text = sTitle
                     .Top = 90
                     .Height = 60
                 End With
     
             End With
         End If
     Next rImage

     'PPApp.Visible = msoTrue
     'RB: if you want to save the ppt file you may be able to modify the next line of code...
     PPPres.SaveAs Filename:=PresentationFileName = Environ("USERPROFILE") & "\Desktop\" & "PMQ Workbench.pptx"
 '    PPres.SaveAs Filename:="c:\PathName\&PresentationFileName=Environ("USERPROFILE")&"\Desktop\"&"MyFile.pptx"
     'PPPres.SaveAs Filename:=PMQWorkbench.ppt
     MsgBox "Output to Powerpoint Complete", vbOKOnly + vbMsgBoxSetForeground, "MACRO HAS FINISHED!"
     ' Clean up
     Set PPSlide = Nothing
     Set PPPres = Nothing
     Set PPApp = Nothing
 '    Set Source_ws = Nothing
 End Sub

Open in new window

Thanks in advance!

B.
0
Comment
Question by:Bright01
  • 5
  • 4
11 Comments
 
LVL 9

Expert Comment

by:Jamie Garroch
ID: 40539784
Hi Bright01. There is a problem with the code as it is because it isn't running correctly for me. The error handling is disabled here:
         'find range or image/chart
         On Error Resume Next

Open in new window

And because it is not re-enabled afterwards with On Error Goto 0, the alignment part is actually throwing an error which you don't see due to an object type error:
                 With myPaste
                     
                     ' Align the pasted range
                     .Align msoAlignCenters, True
                     .Align msoAlignMiddles, True
     
                     ' Position pasted chart
                     .Width = PPPres.PageSetup.SlideWidth - 20
                     .Left = 100
                     .Top = 160
                 End With

Open in new window

I've tried correcting it but without knowing what data is being pasted, it's challenging to secure a fix! So, do you have an example sheet from me to debug with?
0
 

Author Comment

by:Bright01
ID: 40540027
Jamie,

Greetings....and thanks for the help.  I cannot ship you the entire WB; but I have constructed a sample using one of the WSs.  If you run the Print Macro, you will see that it outputs the graphic to your desktop in a ppt.  What I'm trying to do is have it print to ppt and auto. fit the graphic (probably in center).

Thanks again for the assistance.

B.
D--temp-Test-Case-for-Print-to-PPTv2.xls
0
 

Author Comment

by:Bright01
ID: 40540100
Aikimark,

Thanks for the recommendation.  How do I do that?

B.
0
 
LVL 9

Accepted Solution

by:
Jamie Garroch earned 500 total points
ID: 40540127
Try this modified and tested version:

'MODULE FOR OUTPUTING RANGES, OBJECTS AND GRAPHICS TO POWERPOINT
Sub ChartToPPT_vDLMILLE()
Const l_ppPasteEnhancedMetafile = 2
Const ppLayoutBlank = 12

'The "..._v3" version of the code copies pictures from excel whereas the "..._v2" version copies chart objects.
'NO LONGER NEED TO "Set a VBE reference to Microsoft PowerPoint Object Library"
'RB: changed to late binding by changing the powerpoint related declarations to "as object"  (& declaring constants too) to prevent the need for setting a Reference (ie the previous line is no longer necessary).
Const ppViewNormal As Long = 9
Const ppLayoutText As Long = 2
Const SlideMargin = 50 'PowerPoint Slide Margin, added by youpresent.biz (JG)
Dim PPApp As Object 'PowerPoint Application
Dim PPPres As Object 'PowerPoint Presentation
Dim PPSlide As Object 'PowerPoint Slide
Dim PPShape As Object 'PowerPoint Shape, added by youpresent.biz (JG)
Dim PresentationFileName As String
Dim SlideCount As Long
Dim iCht As Long
Dim sTitle As String
Dim rImages As Range
Dim rImage As Range
'Dim myPaste As Object ' youpresent.biz (JG) : No longer required
Dim wkb As Workbook
Dim wks As Worksheet
Dim chkObj As Object

    Set wkb = ThisWorkbook


    'check for an existing instance of PowerPoint & if one doesn't exist then open one.
    On Error Resume Next
    Set PPApp = GetObject(, "Powerpoint.Application")
    On Error GoTo 0
    If PPApp Is Nothing Then
        Set PPApp = CreateObject("Powerpoint.Application")
        PPApp.Visible = msoTrue
    End If

    'DLM:  Check to see if any presentations exist.  Use the existing active presentation if so, or add one if no
    If PPApp.Presentations.Count = 0 Then
        Set PPPres = PPApp.Presentations.Add(msoTrue)
    Else
        Set PPPres = PPApp.ActivePresentation
    End If

    Set rImages = wkb.Names("OutputPPTRanges").RefersToRange
    
    For Each rImage In rImages
    
        'find range or image/chart
        On Error Resume Next
        Set chkObj = wkb.Names(rImage.Value).RefersToRange
        If Err.Number <> 0 Then
            Err.Clear
            For Each wks In wkb.Worksheets
                Set chkObj = wks.Shapes(rImage.Value)
                If Err.Number = 0 Then
                    Exit For
                End If
                Err.Clear
            Next wks
        End If
        
        ' youpresent.biz (JG) : Restore standard error handling
        On Error GoTo 0
        
        chkObj.Copy
        
        If rImage.Value <> vbNullString And Err.Number = 0 Then 'found a valid range from the range name
            
            ' Add a new slide and paste in the chart
            With PPPres.Slides
              SlideCount = .Count
              Set PPSlide = .Add(SlideCount + 1, ppLayoutBlank)
            End With
    
' --------- youpresent.biz (JG) : this With section has been modified to correct positioning errors in original code
            With PPSlide
              .Shapes.PasteSpecial(l_ppPasteEnhancedMetafile).Name = "Excel Import"
              
              Set PPShape = .Shapes("Excel Import")
              
              With PPShape
                ' Lock and size the pasted object
                .LockAspectRatio = msoCTrue
                .Width = PPPres.PageSetup.SlideWidth - SlideMargin
                
                ' Align the pasted object in the centre of the slide
                .Left = (PPPres.PageSetup.SlideWidth - PPShape.Width) / 2
                .Top = (PPPres.PageSetup.SlideHeight - PPShape.Height) / 2
                
                ' The next optional line converts the imported object to a Microsoft Drawing Object which displays it more clearly
                .Ungroup.Name = "Excel Import"
              End With
               
              ' Check that the slide has placeholders before adjusting the first
              If .Shapes.Placeholders.Count > 0 Then
                With .Shapes.Placeholders(1)
                  .TextFrame.TextRange.Text = sTitle
                  .Top = 90
                  .Height = 60
                End With
              End If
' ----------- End of youpresent.biz modifications
    
            End With
        End If
    Next rImage

PresentationFileName = Environ("Userprofile") & "\Desktop\" & "PMQ Workbench.pptx"
PPPres.SaveAs Filename:=PresentationFileName
    
    'PPApp.Visible = msoTrue
    'RB: if you want to save the ppt file you may be able to modify the next line of code...
'    PPPres.SaveAs Filename:=PresentationFileName = Environ("USERPROFILE") & "\Desktop\" & "PMQ Workbench.pptx"
'    PPres.SaveAs Filename:="c:\PathName\&PresentationFileName=Environ("USERPROFILE")&"\Desktop\"&"MyFile.pptx"
    'PPPres.SaveAs Filename:=PMQWorkbench.ppt
    MsgBox "Output to PowerPoint Complete", vbOKOnly + vbMsgBoxSetForeground, "Macro has finished!"
    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
'    Set Source_ws = Nothing
End Sub

Open in new window

0
What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 

Author Comment

by:Bright01
ID: 40540470
Jamie,

This works very well!  I had to comment out one line that was giving me a debug error;

                .Ungroup.Name = "Excel Import"

I think you  mentioned it was optional...... do I need to try to trouble shoot it?

B.
0
 
LVL 9

Expert Comment

by:Jamie Garroch
ID: 40540498
Good news Bright01 :-)

Strange - it worked for me! What version and bitness of MSO are you using?

Before you debug, run the macro without it and then manually ungroup the range object on the PowerPoint side. You should be asked to confirm the conversion to a Microsoft Drawing Object which has the effect of making the resulting object (now a group of native MSO objects) display more clearly. If you see a benefit in that, try changing .Ungroup.Name = "Excel Import" to just .Ungroup which will give it an arbitrary name in the Selection Pane (Alt+F10).
0
 

Author Comment

by:Bright01
ID: 40540550
I ran the macro without the .Ungroup.Name line and it seems to work fine.  I just don't know what I'm missing ;-)   Also, what is MSO?  How do I know what version I'm using?  And will others have a problem with this macro when they run it?
0
 
LVL 9

Expert Comment

by:Jamie Garroch
ID: 40540564
MSO = Microsoft Office (sorry, I should never assume anything!). The optional line is only there to increase the clarity of the pasted object. If you are happy with it as it is (did you try manually ungrouping it to see the difference?) then don't worry - it won't affect other users.
0
 

Author Closing Comment

by:Bright01
ID: 40540582
Jamie,

Great job!  Thanks so much for helping me trouble shoot this problem.  With contribution from 4 EE Pros, I now have a great macro to push the Excel results to PPT.  You have got to love this business model at EE!  Such value.

Again, much thanks,

B.
0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

A2 = A1 That kind of cell reference is relative.  If you copy it from A2 to B2, then B2 will get this: B2 = B1 That's all fine and good, but if you then insert a new row above row 2, you'll find: A3 = A1 B3 = B1 This is intentional. …
Drop Down List with Unique/Distinct Values (Part II - ComboBox or ListBox and Data Validation List Bonus!) David Miller (dlmille) Intro This article focuses on delivering unique, sorted lists to list objects (e.g., ComboBox, ListBox) and Dat…
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now