PPT 修改 标题文本框字体 VBA 批处理

macro_23

1. 
   
2. 'log:
   
3. 'vba makes your daily work efficiently and effectively
   
4. 'created date: 2018-05-18
   
5. 'website for reference:
   
6. 'http://club.excelhome.net/forum.php?mod=viewthread&tid=938911&extra=
   
7. 'http://blog.sina.com.cn/s/blog_4928aeee0101bjvd.html
   
8. 'codes help you to change the fonts in a batch mode with VBA
   
9. 
   
10. 'ajust all fonts in PPT
    
11. 
    
12. Sub font1()
    
13.     Dim mySlide As Slide
    
14.     Dim myShape As Shape
    
15.     Dim myRng   As TextRange
    
16.     With ActivePresentation
    
17.         For Each mySlide In .Slides
    
18.             For Each myShape In mySlide.Shapes
    
19.                 If myShape.HasTextFrame Then
    
20.                     Set myRng = myShape.TextFrame.TextRange
    
21.                     myRng.font.Name = "Arial"  'change font
    
22.                     'myRng.font.Color.RGB = RGB(0, 0, 255)
    
23.                 End If
    
24.             Next
    
25.         Next
    
26.     End With
    
27. End Sub
    
28. 
    
29. 'ajust the font in first textbox for all slides
    
30. Sub font2()
    
31. On Error Resume Next
    
32. Dim oPres As Presentation
    
33. Set oPres = Application.ActivePresentation
    
34. Dim oSlide As Slide
    
35. Dim oShape As Shape
    
36. Dim tr As TextRange
    
37. Dim sText As String
    
38. Dim i As Long, j As Long
    
39. Dim fjd As Integer
    
40. 
    
41. For i = 1 To oPres.Slides.Count  'each slide
    
42.     Set oSlide = oPres.Slides.Item(i)
    
43.    
    
44.     fjd = oSlide.Shapes.Count
    
45.    
    
46.     For j = 1 To 1   'first item as title
    
47.         
    
48.         Set oShape = oSlide.Shapes.Item(j)
    
49.         
    
50.         If oShape.TextFrame.HasText = msoTrue Then
    
51.             Set tr = oShape.TextFrame.TextRange
    
52.             tr.font.NameAscii = "Arial"         'change font
    
53.             tr.font.NameFarEast = "Arial"
    
54.             tr.font.Size = 50
    
55.             'tr.font.Color.RGB = RGB(Red:=255, Green:=192, Blue:=0)
    
56.                      
    
57.             Set tr = Nothing
    
58.         End If
    
59.         Set oShape = Nothing
    
60.     Next j
    
61.    
    
62. Next i
    
63. Set oPres = Nothing
    
64. End Sub
    

复制代码

macro_23

参考附件 测试文件