Solved

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

Posted on 2015-01-08
7
169 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 49

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
Does Powershell have you tied up in knots?

Managing Active Directory does not always have to be complicated.  If you are spending more time trying instead of doing, then it's time to look at something else. For nearly 20 years, AD admins around the world have used one tool for day-to-day AD management: Hyena. Discover why

 

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

Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

823 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