Option Explicit
Public Sub GerarApresentacoesGerar()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim pptApp As Object
Dim pptPresentation As Object
Dim pptSlide As Object
Dim shape As Object
Dim CaminhoModelo As String
Dim CaminhoPastaModelo As String
Dim CaminhoSalvamento As String
Dim NomeArquivoSalvo As String
' Defina o caminho do modelo de PowerPoint (na rede)
CaminhoModelo = [Link] & "\Modelo Comunicação de Ocorrê[Link]"
' Inicialize o aplicativo PowerPoint
Set pptApp = CreateObject("[Link]")
[Link] = True
' Configurar a planilha Excel
Set ws = [Link]("Gerar")
lastRow = [Link]([Link], "A").End(xlUp).Row
' Obtenha o caminho da pasta onde este arquivo Excel está localizado
CaminhoPastaModelo = [Link]
' Loop para percorrer as linhas da tabela
For i = 2 To lastRow ' Começa na linha 2 para evitar o cabeçalho
' Crie uma cópia do modelo
Set pptPresentation = [Link](CaminhoModelo)
' Substituir os marcadores nos shapes do slide
For Each pptSlide In [Link]
For Each shape In [Link]
If [Link] Then
[Link] =
Replace([Link], "{{Data}}", Format([Link](i, 2).Value,
"dd/mm/yyyy"))
[Link] =
Replace([Link], "{{Hora}}", [Link](i, 3).Value)
[Link] =
Replace([Link], "{{Local}}", [Link](i, 4).Value)
[Link] =
Replace([Link], "{{Supervisor}}", [Link](i, 5).Value)
[Link] =
Replace([Link], "{{Atividade}}", [Link](i, 6).Value)
[Link] =
Replace([Link], "{{Tipo de Serviço}}", [Link](i,
7).Value)
[Link] =
Replace([Link], "{{Descrição Detalhada}}", [Link](i,
8).Value)
[Link] =
Replace([Link], "{{Ações Imediatas}}", [Link](i,
9).Value)
' Verifique se o marcador {{Foto 1}} está no texto
If InStr(1, [Link], "{{Foto 1}}",
vbTextCompare) > 0 Then
Dim imagem1 As Object
Set imagem1 = [Link]([Link](i,
10).Value, False, True, [Link], [Link], [Link], [Link])
End If
' Verifique se o marcador {{Foto 2}} está no texto
If InStr(1, [Link], "{{Foto 2}}",
vbTextCompare) > 0 Then
Dim imagem2 As Object
Set imagem2 = [Link]([Link](i,
11).Value, False, True, [Link], [Link], [Link], [Link])
End If
End If
Next shape
Next pptSlide
' Determine o nome do arquivo de destino com base na linha atual (ou seja,
cada apresentação terá um nome de arquivo único)
NomeArquivoSalvo = "Apresentacao_" & i & ".pptx"
' Salve a nova apresentação na pasta atual do arquivo Excel
CaminhoSalvamento = CaminhoPastaModelo & "\" & NomeArquivoSalvo
[Link] CaminhoSalvamento
' Verifique se a apresentação está aberta antes de tentar fechá-la
If Not pptPresentation Is Nothing Then
[Link]
Set pptPresentation = Nothing
End If
Next i
' Feche o aplicativo PowerPoint
[Link]
' Limpando os objetos
Set pptSlide = Nothing
Set pptApp = Nothing
Set ws = Nothing
End Sub