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
.png "VBA Access - Exportando imagens diretamente para os Slides do Powerpoint - VBA Access: Export Images Directly to PowerPoint Slides")
