VBA Access - Exportando imagens diretamente para os Slides do Powerpoint - VBA Access: Export Images Directly to PowerPoint Slides

Digamos que temos uma ou mais tabelas cujo o conteúdo seja o caminho (path) de várias de nossas imagens, fotos ou algum conteúdo gráfico. A partir de uma interface simples com botões na nossa aplicação MS Access, podemos criar slides automaticamente enviado nossas fotos, ilustrações e artes para uma apresentação PPT.

Diversos Dashboards contidos em Planilhas do MS Excel, que podem ser abertas, copiadas como imagem dentro do MS Access e automaticamente exportados para o Powerpoint...Usem a imaginação e divirtam-se!

Option Compare Database
Option Explicit

Sub ExToPpt()

Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShape As PowerPoint.Shape  

Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Open("C:\bernardes\ShowA&APresentation.ppt")
cn.Open CurrentProject.Connection
rs.Open Forms!MyTable.RecordSource, cn 

Do Until rs.EOF

Set pptShape = pptSlide.Shapes.AddPicture(rs.Fields("Picturepath").Value)
rs.Move

Next Loop  

rs.close
cn.close 

Set pptSlide = pptPres.Slides.Add 

End Sub

 2015 

Option Compare Database

Option Explicit

' Sub-rotina para exportar imagens do banco de dados para uma apresentação PowerPoint

Sub ExToPpt()

    ' Declaração de variáveis

    Dim cn As New ADODB.Connection          ' Objeto de conexão com o banco de dados

    Dim rs As New ADODB.Recordset           ' Objeto de conjunto de registros (Recordset) para armazenar os dados

    Dim pptApp As PowerPoint.Application    ' Objeto PowerPoint.Application para interagir com o PowerPoint

    Dim pptPres As PowerPoint.Presentation ' Objeto PowerPoint.Presentation para manipular a apresentação

    Dim pptSlide As PowerPoint.Slide        ' Objeto PowerPoint.Slide para manipular slides da apresentação

    Dim pptShape As PowerPoint.Shape        ' Objeto PowerPoint.Shape para adicionar imagens ao slide

    Dim strSQL As String                    ' Variável para armazenar a consulta SQL para buscar os dados da tabela

    ' Inicia o aplicativo PowerPoint

    Set pptApp = New PowerPoint.Application

    ' Abre a apresentação existente

    On Error GoTo ErrorHandler

    Set pptPres = pptApp.Presentations.Open("C:\bernardes\ShowA&APresentation.ppt")

    ' Abre a conexão com o banco de dados Access

    cn.Open CurrentProject.Connection

    ' Define a consulta SQL a ser usada para recuperar os dados da tabela/formulário

    strSQL = "SELECT Picturepath FROM " & Forms!MyTable.RecordSource

    ' Abre o Recordset com os dados da tabela

    rs.Open strSQL, cn

    ' Verifica se o Recordset contém dados antes de continuar

    If Not rs.EOF Then

        ' Loop para percorrer cada registro do Recordset

        Do Until rs.EOF

            ' Adiciona a imagem do banco de dados ao slide do PowerPoint

            Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutText) ' Adiciona um novo slide

            Set pptShape = pptSlide.Shapes.AddPicture(rs.Fields("Picturepath").Value, _

                MsoTriState.msoFalse, MsoTriState.msoCTrue, 100, 100, -1, -1) ' Adiciona a imagem ao slide

            rs.MoveNext ' Move para o próximo registro

        Loop

    Else

        MsgBox "Nenhuma imagem encontrada na tabela.", vbExclamation, "Aviso"

    End If

    ' Fecha o Recordset e a conexão com o banco de dados

    rs.Close

    cn.Close

    ' Libera os objetos PowerPoint

    pptPres.Save ' Salva a apresentação

    pptPres.Close ' Fecha a apresentação

    pptApp.Quit ' Fecha o PowerPoint

    ' Libera os objetos

    Set pptShape = Nothing

    Set pptSlide = Nothing

    Set pptPres = Nothing

    Set pptApp = Nothing

    Set rs = Nothing

    Set cn = Nothing

    Exit Sub ' Sai da sub-rotina sem erros

ErrorHandler:

    ' Manipulação de erros para garantir que os objetos sejam liberados corretamente

    MsgBox "Erro: " & Err.Description, vbCritical, "Erro"

    On Error GoTo 0 ' Desativa o manipulador de erros

    ' Libera objetos em caso de erro

    Set pptShape = Nothing

    Set pptSlide = Nothing

    Set pptPres = Nothing

    Set pptApp = Nothing

    Set rs = Nothing

    Set cn = Nothing

End Sub

 Clique aqui e nos contate via What's App para avaliarmos seus projetos 

Envie seus comentários e sugestões e compartilhe este artigo!

brazilsalesforceeffectiveness@gmail.com

 Série de Livros nut Project 

  

 PUDIM PROJECT