none
Problema com uma macro ao atualizar o office RRS feed

  • Pergunta

  • Olá, estou com um problema na minha macro que gera uma apresentação no powerpoint.
    Eu utilizava no office 2013, e recentemente atualizei para o 16. Assim que atualizei minha macro parou de rodar. Alguém saberia me ajudar?

    (Deixei em Negrito sublinhado o apontamento da depuração)

    Sub Export_Excel_Charts_to_PowerPoint()

    'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
    Dim ppApp As PowerPoint.Application
    Dim ppSlide As PowerPoint.Slide
    'Dim myChart As Excel.Shape.Group
    Dim cNum As Integer


    Selection.Copy

    'Look for existing instance
    On Error Resume Next
    Set ppApp = GetObject(, "PowerPoint.Application")
    On Error GoTo 0

    'Create new instance if no instance exists
    If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application
    'Add a presentation if none exists
    '''1676If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add

    'Make the instance visible
    ppApp.Visible = True

    num = ppApp.ActivePresentation.Slides.Count


    'Check that a slide exits, if it doesn't add 1 slide. Else use the last slide for the paste operation
    If ppApp.ActivePresentation.Slides.Count = 0 Then
        Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
    Else
        If AddSlidesToEnd Then
            'Appends slides to end of presentation and makes last slide active
            ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
            ppApp.ActiveWindow.View.GotoSlide ppApp.ActivePresentation.Slides.Count
            Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
        Else
        
            'Sets current slide to active slide
            Set ppSlide = ppApp.ActiveWindow.View.Slide
        End If
    End If

    Set ppSlide = ppApp.ActivePresentation.Slides.Add(num + 1, ppLayoutBlank)
    ppApp.ActiveWindow.View.GotoSlide ppApp.ActivePresentation.Slides.Count
    Set ppSlide = ppApp.ActiveWindow.View.Slide
    'Options for Copy & Paste Ranges and Charts



    'ActiveChart.ChartArea.Copy
    ppSlide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile).Select
    'ppSlide.Shapes.PasteSpecial(DataType:=3).Select
    'ppSlide.Shapes.Paste.Select

    For Each xLink In ppSlide.Hyperlinks
            xLink.Delete
    Next xLink


    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, msoTrue
    ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
    'ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMidles, msoTrue
    ppApp.ActiveWindow.Selection.ShapeRange.IncrementTop 100

    AppActivate ("PowerPoint")

    Set ppSlide = Nothing
    Set ppApp = Nothing

    'Call Application.OnTime(Now + TimeValue("00:00:02"), "ExecutaOnTime")

    AppActivate ("Microsoft Excel")

    End Sub

    Public Sub ExecutaOnTime()
        AppActivate ("Microsoft Excel")
    End Sub

    terça-feira, 28 de novembro de 2017 16:24