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

如果您想这样做，您需要将 Export 行移到 Do While 之外。在下面的修改代码中，我添加了一个标志，如果找到至少一个关键字，则设置该标志，然后在完全检查 TargetList 后，如果标志为真，则幻灯片以“幻灯片 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： 如果 Err 0 那么 MsgBox Err.Description 万一 结束子