VBA將PPT中有顔色的文本內容全部改爲粗體

VBA將PPT中有顔色的文本內容全部改爲粗體

On Error Resume Next


'''''''''''''''''''''''''''''''''''''''''開始取消組閤'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

For i = 1 To ActivePresentation.Slides.Count
    For Each shp In Application.ActivePresentation.Slides(i).Shapes
    
        If shp.Type = msoGroup Then
            shp.Ungroup
        End If
    Next
Next
    

'''''''''''''''''''''''''''''''''''''''''以下開始對加粗字體'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Dim myshp As Shape
'tmtony 
For i = 1 To ActivePresentation.Slides.Count
    For k = 1 To Application.ActivePresentation.Slides(i).Shapes.Count
        Set myshp = Application.ActivePresentation.Slides(i).Shapes(k)
        nm = Application.ActivePresentation.Slides(i).Shapes(k).Name  '14 msoPlaceholder  17爲文本框   msoAutoShape 1  'msoInkComment = 23  22  13爲圖片  msoLine = 9
          
 
        If myshp.Type = 1 Or myshp.Type = 14 Or myshp.Type = 17 Then
           
            For j = 1 To Len(Application.ActivePresentation.Slides(i).Shapes(k).TextFrame.TextRange.Text)
         
                If Application.ActivePresentation.Slides(i).Shapes(k).TextFrame.TextRange.Characters(Start:=j, Length:=1).Font.Color.RGB <> RGB(Red:=255, Green:=255, Blue:=255) Then
 
 ‘www.office-cn.net                  Application.ActivePresentation.Slides(i).Shapes(k).TextFrame.TextRange.Characters(Start:=j, Length:=1).Font.Bold = msoTrue
                End If
            Next
        End If

    Next k
Next i
MsgBox "處理完畢！"