Powerpoint VBA сохраняет слайды с ключевым словом как JPEG

Question

В настоящее время у меня есть макрос в PowerPoint, который находит ключевые слова в файле PowerPoint и сохраняет слайды, содержащие ключевые слова, в виде файлов JPEG. Тем не менее, я заметил, что, поскольку код проходит через каждую форму, он сохраняет файл до того, как будет найдено каждое ключевое слово в слайде, таким образом, создано много файлов JPEG с одной и той же страницей слайдов, но с одним ключевым словом, подсвеченным каждый раз, есть ли способ сделать макрос распечатать слайд после каждого ключевого слова, найденного на этом слайде?

Код:

Option Explicit 

Sub fgdg() 

Dim sImagePath As String 
Dim sImageName As String 
Dim lScaleWidth As Long '* Scale Width 
Dim lScaleHeight As Long '* Scale Height 
Dim sld As Slide 
Dim shp As Shape 
Dim txtRng As TextRange, rngFound As TextRange 
Dim i As Long, n As Long 
Dim TargetList 
On Error GoTo Err_ImageSave 
'~~> EDIT THE ITEMS IN THE ARRAY() TO FIND DESIRED WORD(S) 
TargetList = Array("doodle") 

'~~> Loop through each slide 
For Each sld In Application.ActivePresentation.Slides 
    '~~> Loop through each shape 
    For Each shp In sld.Shapes 
     '~~> Check if it has text 
     If shp.HasTextFrame Then 
      Set txtRng = shp.TextFrame.TextRange 
      sImagePath = "D:/" 
      For i = 0 To UBound(TargetList) 
       '~~> Find the text 
       Set rngFound = txtRng.Find(TargetList(i)) 

       '~~~> If found 
       Do While Not rngFound Is Nothing 
        '~~> Set the marker so that the next find starts from here 
        n = rngFound.Start + 1 
        '~~> Change attributes 
        With rngFound.Font 
         .Bold = msoTrue 
         .Underline = msoTrue 
         .Italic = msoTrue 
         .Color.RGB = RGB(255, 255, 0) 
         sImageName = rngFound.Start & ".jpg" 
         sld.Export sImagePath & sImageName, "JPG" 
         '~~> Find Next instance 
         Set rngFound = txtRng.Find(TargetList(i), n) 

        End With 
       Loop 
      Next 
     End If 
    Next 
Next 
Err_ImageSave: 
    If Err <> 0 Then 
     MsgBox Err.Description 
    End If 
End Sub 

Answer 1

Вы должны переместить линию экспорта за пределами Do While, если вы хотите, чтобы сделать это. В модифицированном коде ниже я добавил флаг, который установлен, если найдено хотя бы одно ключевое слово, а затем, как только TargetList был полностью проверен, если флаг имеет значение true, слайд экспортируется в формате «Slide X.jpg». Код не проверен.

Option Explicit 

Sub fgdg() 

Dim sImagePath As String 
Dim sImageName As String 
Dim lScaleWidth As Long '* Scale Width 
Dim lScaleHeight As Long '* Scale Height 
Dim sld As Slide 
Dim shp As Shape 
Dim txtRng As TextRange, rngFound As TextRange 
Dim i As Long, n As Long 
Dim TargetList 
Dim bFound As Boolean 
On Error GoTo Err_ImageSave 
'~~> EDIT THE ITEMS IN THE ARRAY() TO FIND DESIRED WORD(S) 
TargetList = Array("doodle") 

'~~> Loop through each slide 
For Each sld In Application.ActivePresentation.Slides 
    '~~> Reset the found flag 
    bFound = False 
    '~~> Loop through each shape 
    For Each shp In sld.Shapes 
     '~~> Check if it has text 
     If shp.HasTextFrame Then 
      Set txtRng = shp.TextFrame.TextRange 
      sImagePath = "D:/" 
      For i = 0 To UBound(TargetList) 
       '~~> Find the text 
       Set rngFound = txtRng.Find(TargetList(i)) 

       '~~~> If found 
       Do While Not rngFound Is Nothing 
        '~~> Set a flag to indicate that at least one keyword has been found 
        bFound = True 
        '~~> Set the marker so that the next find starts from here 
        n = rngFound.Start + 1 
        '~~> Change attributes 
        With rngFound.Font 
         .Bold = msoTrue 
         .Underline = msoTrue 
         .Italic = msoTrue 
         .Color.RGB = RGB(255, 255, 0) 
         'sImageName = rngFound.Start & ".jpg" 
         'sld.Export sImagePath & sImageName, "JPG" 
         '~~> Find Next instance 
         Set rngFound = txtRng.Find(TargetList(i), n) 
        End With 
       Loop 
      Next 
      '~~> If at least one keyword was found, export the slide 
      If bFound Then sld.Export sImagePath & "Slide " & sld.SlideIndex, "JPG" 
     End If 
    Next 
Next 

Err_ImageSave: If Err <> 0 Тогда MsgBox Err.Description End If End Sub