word里加粗的内容如何在PPT里统一成黄色

djwhjy

各位大神，请教一个困惑已久的问题。因工作需要，经常需要把word的内容复制到PPT里，但是word里有很多内容加了粗，粘贴到PPT里就没有加粗了，PPT的要求是：强调的内容统一成黄色。

我可以在word里把强调的内容前后加上特殊符号，例如做成这样：#强调内容$，想问下大神，怎么在PPT中一次性把“#$”这两个符号中间的内容统一成黄色
问题.rar (594.66 KB, 下载次数: 7)

2018-7-26 12:00 上传

点击文件名下载附件

先谢过各位大神了

leikaiyi123

你的ppt里不是有现成的代码么？只需要改一下正则就行了。

Sub PptRegexMatch2() '正则查找/替换
' 好吧，你打开PowerPoint的查找/替换，就知道有多坑！！！
' 好吧，用VBScript的正则功能来弥补，来增强
' 正则可以自拟，参考：http://msdn.microsoft.com/en-us/library/ms974570.aspx
' 颜色值亦可自拟。。。
    Dim oSld As Slide, oShp As Shape
    Dim lRGB As Long
    Dim strPattern As String
    Dim oRange As TextRange
    Dim i As Integer, iPos As Integer, iLen As Integer
    ' 正则相关变量
    Dim regx As Object
    Dim oMatch As Object

    ' 这里写颜色值
    lRGB = RGB(255, 255, 0)
    ' 这里写查找的正则
    'strPattern = "【(例\d+.*?|答案|考点|解析)】"
    strPattern = "(\#.*?\$)" '#$

    Set regx = CreateObject("vbscript.regexp")
    With regx
        .Global = True
        .IgnoreCase = True
        .Pattern = strPattern
    End With

    For Each oSld In ActivePresentation.Slides
        For Each oShp In oSld.Shapes
            If oShp.HasTextFrame Then
                If oShp.TextFrame.HasText Then

                    Set oRange = oShp.TextFrame.TextRange

                    With oShp.TextFrame.TextRange
                        ' 可能会出现多个匹配项的
                        If (regx.test(.Text) = True) Then
                            Set oMatch = regx.Execute(.Text)
                            For i = 0 To oMatch.Count - 1
                                'Debug.Print oMatch(i).Value
                                iPos = oMatch(i).Firstindex
                                iLen = oMatch(i).Length
                                oRange.Characters(iPos + 1, iLen).Font.Color.RGB = lRGB
                            Next i
                        End If
                    End With

                End If
            End If

        Next oShp
    Next oSld

    Set regx = Nothing
End Sub

经测试上面代码，2010版中没问题，2003版中有小问题，要适当修改。

dongdonggege

leikaiyi123 发表于 2018-7-27 13:03
你的ppt里不是有现成的代码么？只需要改一下正则就行了。

Sub PptRegexMatch2() '正则查找/替换

楼主说：把“#$”这两个符号中间的内容统一成黄色。不应该包括“#$”符号
oRange.Characters(iPos + 2, iLen - 2).Font.Color.RGB = lRGB

djwhjy

leikaiyi123 发表于 2018-7-27 13:03
你的ppt里不是有现成的代码么？只需要改一下正则就行了。

Sub PptRegexMatch2() '正则查找/替换

试了下，没问题，太感谢您了，帮了我大忙

djwhjy

leikaiyi123 发表于 2018-7-27 13:03
你的ppt里不是有现成的代码么？只需要改一下正则就行了。

Sub PptRegexMatch2() '正则查找/替换

大神，这个宏对文本框有效，如何让他对表格也有效呢？

djwhjy

dongdonggege 发表于 2018-7-27 20:45
楼主说：把“#$”这两个符号中间的内容统一成黄色。不应该包括“#$”符号
oRange.Characters(iPos + 2,  ...

运行完宏，把#$删掉就行了，所以不用处理符号。多谢您的严谨！

leikaiyi123

dongdonggege 发表于 2018-7-27 20:45
楼主说：把“#$”这两个符号中间的内容统一成黄色。不应该包括“#$”符号
oRange.Characters(iPos + 2,  ...

增加了包含表格的判断，为什么正则没执行，帮忙看下？谢谢。
Sub PptRegexMatch2()    '正则查找/替换-----把文中“#$”两个符号之间的内容变成黄色,ppt2010版通过，ppt2003版分段后有问题
' 好吧，你打开PowerPoint的查找/替换，就知道有多坑！！！
' 好吧，用VBScript的正则功能来弥补，来增强
' 正则可以自拟，参考：http://msdn.microsoft.com/en-us/library/ms974570.aspx
' 颜色值亦可自拟。。。
    Dim oSld As Slide, oShp As Shape
    Dim lRGB As Long
    Dim strPattern As String
    Dim oRange As TextRange
    Dim i As Integer, iPos As Integer, iLen As Integer
    ' 正则相关变量
    Dim regx As Object
    Dim oMatch As Object
    Dim oRow As Row

    ' 这里写颜色值
    lRGB = RGB(255, 255, 0)
    ' 这里写查找的正则
    'strPattern = "【(例\d+.*?|答案|考点|解析)】"
    strPattern = "(\#.*?\$)"    '"\#.*?\$"

    Set regx = CreateObject("vbscript.regexp")
    With regx
        .Global = True
        .IgnoreCase = True
        .Pattern = strPattern
    End With

    For Each oSld In ActivePresentation.Slides
        For Each oShp In oSld.Shapes
            If oShp.HasTable Then
                For Each oRow In oShp.Table.Rows
                    For j = 1 To oRow.Cells.Count
                        If oRow.Cells(j).Shape.TextFrame.HasText Then
                            Set oRange = oRow.Cells(j).Shape.TextFrame.TextRange
                            With oRow.Cells(j).Shape.TextFrame.TextRange
                                If (regx.test(.Text) = True) Then '为什么这个判断执行不了？
                                    Set oMatch = regx.Execute(.Text)
                                    For i = 0 To oMatch.Count - 1
                                        iPos = oMatch(i).Firstindex
                                        iLen = oMatch(i).Length
                                        oRange.Characters(iPos + 2, iLen - 2).Font.Color.RGB = lRGB
                                    Next i
                                End If
                            End With
                        End If
                    Next j
                Next
            End If

            If oShp.HasTextFrame Then
                If oShp.TextFrame.HasText Then
                    Set oRange = oShp.TextFrame.TextRange
                    With oShp.TextFrame.TextRange
                        If (regx.test(.Text) = True) Then
                            Set oMatch = regx.Execute(.Text)
                            For i = 0 To oMatch.Count - 1
                                iPos = oMatch(i).Firstindex
                                iLen = oMatch(i).Length
                                oRange.Characters(iPos + 2, iLen - 2).Font.Color.RGB = lRGB
                            Next i
                        End If
                    End With

                End If
            End If
        Next oShp
    Next oSld
    Set regx = Nothing
End Sub

djwhjy

13版都可以执行，感谢大神