使用VBA将pptx文件转换为jpg

Question

我有一个充满 pptx 文件的文件夹，以及一个通过 VBA 从 excel 表中生成 pptx 文件的代码库，我需要在这段代码中放入一个步骤，将 pptx 文件转换为 jpg，它可以在创建文件之后或期间，按照下面的代码进行操作

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

Answer 1

您只需要添加一行代码；这会将幻灯片 1 导出为 Auto_1.JPG，将幻灯片 2 导出为 Auto_2.JPG，依此类推。 使用 .Export 逐张滑动可以指定所需的 JPG 分辨率和导出的 JPG 的名称（.SaveAs 不允许这样做）。

一个建议：变量名不要使用PPT对象的名称；例如，使用sl 或（更常见的）oSl 或oSld（o 表示它是一个对象）而不是幻灯片。

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
    'ADD THIS:
    Dim sPath as String
    sPath = ActivePresentation.Path & "\" ' Assuming Windows, not Mac
    Call slide.Export(sPath & "Auto_" & cstr(slide.slideindex) _
        & ".JPG", "JPG", 1024, 768)
Next slide