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，如果标志为真，则幻灯片以＃34;幻灯片X的格式导出。 JPG＆＃34 ;.代码未经测试。

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＆lt;＆gt; 0然后 MsgBox Err.Description 万一结束子

Powerpoint VBA使用关键字JPEG格式保存幻灯片

1 个答案: