Option Explicit
Public Sub GerarApresentacoes()
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]
%20Compartilhados/General/APRESENTA%C3%87%C3%95ES/MODELO%20APRESENTA%C3%87%C3%83O/
Modelo de Inspeçã[Link]"
' Inicialize o aplicativo PowerPoint
Set pptApp = CreateObject("[Link]")
[Link] = True
' Configurar a planilha Excel
Set ws = [Link]("Inicio")
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], "{{Local da Inspeção}}", [Link](i,
2).Value)
[Link] =
Replace([Link], "{{DATA}}", [Link](i, 3).Value)
[Link] =
Replace([Link], "{{NOME DA EMPRESA}}", [Link](i,
4).Value)
[Link] =
Replace([Link], "{{Descreva detalhadamente o que
ocorreu}}", [Link](i, 5).Value)
[Link] =
Replace([Link], "{{Descreva a ação definitiva 1}}",
[Link](i, 6).Value)
[Link] =
Replace([Link], "{{Descreva a ação definitiva 2}}",
[Link](i, 7).Value)
[Link] =
Replace([Link], "{{Nome do Responsável pela Ação
Definitiva}}", [Link](i, 8).Value)
' Verifique se o marcador {{Adicione as evidências}} está no
texto
If InStr(1, [Link], "{{Adicione as
evidências}}", vbTextCompare) > 0 Then
' Divida as evidências em uma matriz
Dim evidencias As Variant
evidencias = Split([Link](i, 9).Value, ";")
Dim topPos As Single
topPos = [Link]
Dim leftPos As Single
leftPos = [Link]
' Adicione as evidências como imagens
Dim evidenciaLink As Variant
For Each evidenciaLink In evidencias
If Len(evidenciaLink) > 0 Then
' Certifique-se de que a evidenciaLink é um URL
válido
If Left(evidenciaLink, 4) = "http" Then
[Link] "Adicionando imagem: " &
evidenciaLink
' Adicione a imagem ao slide
[Link] evidenciaLink,
False, True, leftPos, topPos
' Atualize a posição para a próxima imagem
topPos = topPos + 100
Else
[Link] "URL inválido: " & evidenciaLink
End If
End If
Next evidenciaLink
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