Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.
One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.
Thanks in advance!
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
Add your voice to the tech community where 5M+ people just like you are talking about what matters.
Join the community of 500,000 technology professionals and ask your questions.