office交流網--QQ交流群號

Access培訓群:792054000         Excel免費交流群群:686050929          Outlook交流群:221378704    

Word交流群:218156588             PPT交流群:324131555

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

2020-05-08 08:00:00
zstmtony
原創
3814

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 "處理完畢!"

    分享