加载中…
个人资料
微博
  • 博客等级：
  • 博客积分：
  • 博客访问：
  • 关注人气：
  • 获赠金笔：0支
  • 赠出金笔：0支
  • 荣誉徽章：
正文 字体大小：大 中 小

ppt vba 批量修改文字框的位子大小和颜色

(2012-12-19 14:17:23)
标签：

杂谈
Sub Text()
On Error Resume Next
Dim oPres As Presentation
Set oPres = Application.ActivePresentation
Dim oSlide As Slide
Dim oShape As Shape
Dim tr As TextRange
Dim sText As String
Dim i As Long, j As Long
Dim fjd As Integer

'循环每页幻灯
For i = 1 To oPres.Slides.Count
    Set oSlide = oPres.Slides.Item(i)
    
    fjd = oSlide.Shapes.Count
    
    '判断ppt里有2个文本框
    
    If fjd = 2 Then
    
    For j = 1 To 1
        
        Set oShape = oSlide.Shapes.Item(j)
       
        With oShape
            .Left = 50
            .Top = 20
            .Width = 570
        End With
        
        If oShape.TextFrame.HasText = msoTrue Then
            Set tr = oShape.TextFrame.TextRange
            tr.Font.NameAscii = "黑体"
            tr.Font.NameFarEast = "黑体"
            tr.Font.Size = 28
            tr.Font.Color.SchemeColor = ppBackground
            Set tr = Nothing
        End If
       
        Set oShape = Nothing
    Next
    
    For j = 2 To 2
        
        Set oShape = oSlide.Shapes.Item(j)
       
        With oShape
            .Left = 50
            .Top = 100
            .Width = 570
        End With
        
        If oShape.TextFrame.HasText = msoTrue Then
            Set tr = oShape.TextFrame.TextRange
            tr.Font.NameAscii = "黑体"
            tr.Font.NameFarEast = "黑体"
            tr.Font.Size = 26
            tr.Font.Color.RGB = RGB(Red:=255, Green:=192, Blue:=0)
            
            
              Set tr = Nothing
        End If
        Set oShape = Nothing
    Next
    
    Else
    
 For j = 1 To 1
        
        Set oShape = oSlide.Shapes.Item(j)
       
        With oShape
            .Left = 50
            .Top = 100
            .Width = 570
        End With
        If oShape.TextFrame.HasText = msoTrue Then
            Set tr = oShape.TextFrame.TextRange
            tr.Font.NameAscii = "黑体"
            tr.Font.NameFarEast = "黑体"
            tr.Font.Size = 26
            tr.Font.Color.RGB = RGB(Red:=255, Green:=192, Blue:=0)
            
            
              Set tr = Nothing
        End If
        Set oShape = Nothing
    Next
    
    
    End If




    
    Set oSlide = Nothing
Next
Set oPres = Nothing
End Sub


Sub Text()
On Error Resume Next
Dim oPres As Presentation
Set oPres = Application.ActivePresentation
Dim oSlide As Slide
Dim oShape As Shape
Dim tr As TextRange
Dim sText As String
Dim i As Long, j As Long
'循环每页幻灯
For i = 1 To oPres.Slides.Count
    Set oSlide = oPres.Slides.Item(i)
    
    
    
    
    For j = 1 To 1
        
        Set oShape = oSlide.Shapes.Item(j)
       
        With oShape
            .Left = 50
            .Top = 20
            .Width = 570
        End With
        Set oShape = Nothing
    Next
    
    
    For j = 2 To 2
        
        Set oShape = oSlide.Shapes.Item(j)
       
        With oShape
            .Left = 50
            .Top = 200
            .Width = 570
        End With
        Set oShape = Nothing
    Next
    
    
    
    Set oSlide = Nothing
Next
Set oPres = Nothing
End Sub

喜欢

0

阅读┊ 收藏 ┊ 喜欢▼ ┊打印┊举报/Report
  

新浪BLOG意见反馈留言板　欢迎批评指正

新浪简介 | About Sina | 广告服务 | 联系我们 | 招聘信息 | 网站律师 | SINA English | 产品答疑

Copyright © 1996 - 2022 SINA Corporation, All Rights Reserved

新浪公司 版权所有