2021-07-28

Transform pptx file to jpg with VBA

I have a folder full of pptx files, and a code base that generates pptx files from a table in excel, via VBA, I need to put in this code a step in which I transform the pptx file into jpg, it can be after creating the file or during, follow code below

Option Explicit

Public Sub GerarPPTS()

    Dim tb As ListObject 'ListObject é uma tabela
    Dim Linha As ListRow
    
    Dim ppt             As Object 'PowerPoint.Application
    Dim apresentacao As Object 'PowerPoint.Presentation
    Dim slide       As Object 'PowerPoint.slide
    Dim sp          As Object 'PowerPoint.Shape
    
    'Set o objeto Tabela que é Objeto de lista
    Set tb = wsInicio.ListObjects("tbPEssoas")
    
    'Gerar um PPT APLICAÇÂo
    Set ppt = CreateObject("Powerpoint.Application") 'ew PowerPoint.Application
    ppt.Visible = True
         
    'Loopar as linhas da tabela
    For Each Linha In tb.ListRows
        
         'Criando uma Apresentação
         'Baseada num modelo
         Set apresentacao = ppt.Presentations.Open(ThisWorkbook.Path & "\ANIVERSARIANTE Auto.pptx")
        'Loopar os Slides trocando as variaveis
        'do PPT pelos valores do Excel
    
        'Tenta alterar o texto de TODOS
        'os shapes e se der erro continua
        On Error Resume Next
        For Each slide In apresentacao.Slides
            For Each sp In slide.Shapes
                sp.TextFrame.TextRange.Text = VBA.Replace(sp.TextFrame.TextRange.Text, "@NOME", Linha.Range(1, 1))
                sp.TextFrame.TextRange.Text = VBA.Replace(sp.TextFrame.TextRange.Text, "@DATA", Linha.Range(1, 2))
            
            Next sp
        Next slide
        'Desliga o tratamento de erro malucop
        On Error GoTo 0
        
        'SALVA O ARQUIVO NO LUGAR DESEJADO
        apresentacao.SaveCopyAs ThisWorkbook.Path & "\" & Linha.Range(1, 1) & ".pptx"
        VBA.DoEvents
    Next Linha
   
    'FECHA O POWERPOINT
    ppt.Quit
    Set ppt = Nothing
    
End Sub


from Recent Questions - Stack Overflow https://ift.tt/3zG3YmD
https://ift.tt/eA8V8J

No comments:

Post a Comment