Solved

Output from Excel Graphics to PPT - Slight modification for file name/location

Posted on 2015-01-08
7
167 Views
Last Modified: 2015-01-08
EE Pros;

I have a great Macro that DMille and JRWilson helped me with back in 2012.  I'm trying to use it again in a new spreadsheet.  Here is my problem.  I've created the range names but when I run this macro, I can't find where it has placed the output (the new PPT).  I think it's in the last section of this macro or I may need to specify it on the line;

    PPPres.SaveAs Filename:=PresentationFileName

Thank you for taking a look at this for me.

B.


'MODULE FOR OUTPUTING RANGES, OBJECTS AND GRAPHICS TO POWERPOINT

Const l_ppPasteEnhancedMetafile = 3
Const ppLayoutBlank = 12
Sub ChartToPPT_vDLMILLE()
'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
                    .Left = 10
                    .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

    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
0
Comment
Question by:Bright01
  • 2
  • 2
  • 2
  • +1
7 Comments
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 40537657
Hi,

In you code no value is assigned to

PresentationFileName

Regards
0
 
LVL 24

Expert Comment

by:Phillip Burton
ID: 40537658
Add the path name before PresentationFileName, e.g.

PPPres.SaveAs Filename:="c:\PathName\" & PresentationFileName
0
 
LVL 23

Expert Comment

by:JSRWilson
ID: 40537669
PresentationFileName doesn't ever seem to be set to an address.

Add this

PresentationFileName=Environ("USERPROFILE")  & "\Desktop\" & "MyFile.pptx"

It should then end up on the desktop called MyFile.pptx
0
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 

Author Comment

by:Bright01
ID: 40537909
John and Phillip,

I think I made the changes you suggested (I actually am only using John's as indicated below....but tried both ways).  It's still not printing to the desktop.  

Any ideas?

Much thanks,

B.


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
0
 
LVL 24

Assisted Solution

by:Phillip Burton
Phillip Burton earned 200 total points
ID: 40537919
There are mistakes in both of the above. Both

PPPres.SaveAs Filename:=PresentationFileName = Environ("USERPROFILE") & "\Desktop\" & "PMQ Workbench.pptx"

and

'    PPres.SaveAs Filename:="c:\PathName\&PresentationFileName=Environ("USERPROFILE")&"\Desktop\"&"MyFile.pptx"

should read

PPPres.SaveAs Filename:= Environ("USERPROFILE") & "\Desktop\" & "PMQ Workbench.pptx"
0
 
LVL 23

Accepted Solution

by:
JSRWilson earned 300 total points
ID: 40537947
I was suggesting something like

PresentationFileName = Environ("USERPROFILE") & "\Desktop\" & "PMQ Workbench.pptx"
PPPres.SaveAs Filename:=PresentationFileName
0
 

Author Closing Comment

by:Bright01
ID: 40538008
John and Phillip,  GREAT JOB!  I used John's code in the end but both solutions are very helpful.  Thank you so much for the quick response.  I'm now turning attention to defining the graphics that will go into the PPT and properly naming the PPT as it is placed on the desktop.  I'll probably be authoring some more questions on this code.  Thanks again.... really appreciate the help and support.   I don't know how you guys got so good on such coding.

B.
0

Featured Post

Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
Introduction In all recent versions of PowerPoint it is possible to trigger animations. This means the animation takes place when a certain shape is clicked. This allows you to run animation “on demand” and outwith the normal sequence of mouse cl…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.

705 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