none
ajuda com código para copiar e colar do excel para o PPT RRS feed

  • Pergunta

  • encontrei o código abaixo que é uma função para copiar e colar do excel para o ppt, tentei utiiza-lo porém sem sucesso, alguem que já utilizou este pode por gentileza me explicar como funciona, é que mensalmen tenho que atualizar 4 apresentação, com varias planilhas (range dados) e graficos, que juntas somam 75 slides. segueo código encontrado. http://www.ehow.com/how_5551671_automatically-powerpoint-using-vba-macro.html

    Sub Macro5()
    '
    '
    Dim PPT As PowerPoint.Application
    Set PPT = New PowerPoint.Application
    PPT.Visible = True
    PPT.Presentations.Open Filename:="C:\Location\of\powerpoint\presentation\filename.ppt"

    End Sub

    Public Function copy_chart(sheet, chart_name, slide, awidth, aheight, atop, aleft)

    Sheets(sheet).Select

    ' Set a VBE reference to Microsoft PowerPoint Object Library

    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.slide


    ' Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    ' Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    PPApp.ActiveWindow.ViewType = ppViewSlide
    PPApp.ActiveWindow.View.GotoSlide (slide)
    ' Reference active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    ActiveSheet.ChartObjects(chart_name).Activate
    ActiveChart.ChartArea.Copy

    PPSlide.Select
    PPSlide.Shapes.PasteSpecial ppPastePNG
    PPSlide.Select
    PPSlide.Shapes(PPSlide.Shapes.Count).Select

    Dim sr As PowerPoint.ShapeRange
    Set sr = PPApp.ActiveWindow.Selection.ShapeRange

    ' Resize:
    sr.Width = awidth
    sr.Height = aheight

    If sr.Width > 700 Then
    sr.Width = 700
    End If
    If sr.Height > 420 Then
    sr.Height = 420
    End If
    ' Realign:
    sr.Align msoAlignCenters, True
    sr.Align msoAlignMiddles, True
    sr.Top = atop

    If aleft <> 0 Then
    sr.Left = aleft
    End If

    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing

    End Function

    Public Function copy_range(sheet, rowStart, columnStart, row_count, columnCount, slide, aheight, awidth, atop, aleft)

    Sheets(sheet).Select
    Cells(rowStart, columnStart).Resize(row_count, columnCount).Select

    ' Make sure a range is selected
    If Not TypeName(Selection) = "Range" Then
    MsgBox "Please select a worksheet range and try again.", vbExclamation, _
    "No Range Selected"
    Else

    ' Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    ' Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    PPApp.ActiveWindow.ViewType = ppViewSlide
    PPApp.ActiveWindow.View.GotoSlide (slide)
    ' Reference active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    ' Copy the range as a picture
    Selection.CopyPicture Appearance:=xlScreen, _
    Format:=xlBitmap

    ' Paste the range
    PPSlide.Shapes.Paste.Select

    Dim sr As PowerPoint.ShapeRange
    Set sr = PPApp.ActiveWindow.Selection.ShapeRange

    ' Resize:
    sr.Width = awidth
    sr.Height = aheight

    If sr.Width > 700 Then
    sr.Width = 700
    End If
    If sr.Height > 420 Then
    sr.Height = 420
    End If
    ' Realign:
    sr.Align msoAlignCenters, True
    sr.Align msoAlignMiddles, True
    sr.Top = atop

    If aleft <> 0 Then
    sr.Left = aleft
    End If

    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing
    End If

    End Function


    Public Function copy_text(sheet, rowStart, columnStart, row_count, columnCount, slide, textbox)

    Sheets(sheet).Select
    Text = Cells(rowStart, columnStart).Resize(row_count, columnCount).Text


    ' Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    ' Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    PPApp.ActiveWindow.ViewType = ppViewSlide
    PPApp.ActiveWindow.View.GotoSlide (slide)
    ' Reference active slide
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)

    PPSlide.Shapes(textbox).TextFrame.TextRange = Text


    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing

    End Function


    Public Function add_slide()

    ' Reference existing instance of PowerPoint
    Set PPApp = GetObject(, "Powerpoint.Application")
    ' Reference active presentation
    Set PPPres = PPApp.ActivePresentation
    'create new slide
    PPApp.Activate
    PPPres.Slides.AddSlide PPPres.Slides.Count + 1, PPPres.SlideMaster.CustomLayouts(2)

    End Function

     

    sexta-feira, 4 de março de 2011 04:08

Todas as Respostas

  • Qual foi EXATAMENTE o problema que teve? Em qual linha de código parou? Qual a mensagem de erro?
    Luiz Cláudio Cosenza Vieira da Rocha - http://msmvps.com/blogs/officedev - IT Lab www.itlab.com.br - Access FAQ: www.accessfaq.com.br
    domingo, 6 de março de 2011 17:47
    Moderador