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

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

Powerpoint VBA 将带有关键字的幻灯片保存为 JPEG

Powerpoint VBA save slides with keyword as JPEG

powerpoint

vba