注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

wangkai的博客

写不出长遍大论, 只记一些随笔, 一些瞬间想法, 或记一些技术, 以便来日回忆

 
 
 

日志

 
 

VBA宏(for meggie)  

2011-08-02 22:22:20|  分类: VBA |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |
Sub 设置PPT选中对象_位置为left为085cmTop为0_标题内部文字段落为0点8倍行距()
    ' 用于调整PPT文档标题的宏(Alex的第一个VBA宏, 有点简单,呵)
    '   选中标题对象
    '   设置PPT每页_标题位置为left=0.85cm, top=0.85cm
    '   内部文字段落为0.8倍行距
    '     for my wife(Meggie), wangkaisino@gmail.com
    '
    Set a = ActiveWindow.Selection
    With a
        .ShapeRange.Left = 24 
        .ShapeRange.Top = 24
    End With

    Set txtRange = ActiveWindow.Selection.ShapeRange.TextFrame.TextRange
    txtRange.Select
    With txtRange.ParagraphFormat
        .SpaceWithin = 0.8
    End With
End Sub

Sub 设置PPT选中对象_行距为12磅()
    ' 设置PPT选中对象_行距为12磅的宏(Alex的第三个VBA宏,呵)
    '   选中对象
    '   设置行距为12磅
    '     for my wife(Meggie), wangkaisino@gmail.com
    '
    Set txtRange = ActiveWindow.Selection.ShapeRange.TextFrame.TextRange
    txtRange.Select
    With txtRange.ParagraphFormat
        .LineRuleWithin = False
        .SpaceWithin = 12
    End With
End Sub

Sub 设置PPT选中对象_字体字号_v1点1()
    ' 设置PPT选中对象_字体的宏(Alex的第四个VBA宏,呵)
    '   选中对象
    '   设置字体为Arial, 字号为12
    '     for my wife(Meggie), wangkaisino@gmail.com
    '
    '  Ver 1.1     2011-08-03 13:00
    '   change log: 可以选择多个幻灯片, 对其内部的文本框设置字体与大小. 也可选择一个幻灯片内部的多个组件, 对多个组件设置字体与大小
    
    ChangeFontName = "Arial"        '如果changeFontName == "" 则不做更改
    ChangeFontSize = 12             '如果ChangeFontSize <= 0, 则不做更改  
    
    Dim selection As selection
    Set selection = ActiveWindow.selection
    Dim selType As PpSelectionType
    selType = selection.Type
    
    If selType = ppSelectionNone Then
        MsgBox ("请选择对象, 再调用此宏")
        Exit Sub
    ElseIf selType = ppSelectionShapes Then
        shapeCount = selection.shapeRange.Count
        For Index = 1 To shapeCount
            With selection.shapeRange(Index).TextFrame.TextRange.Font
                If ChangeFontName <> "" Then
                    .Name = ChangeFontName
                End If
                
                If ChangeFontSize > 0 Then
                    .Size = ChangeFontSize
                End If
            End With
        Next Index
    ElseIf selType = ppSelectionSlides Then
        Dim slides As SlideRange
        Set slides = selection.SlideRange
        pageCount = slides.Count
        If pageCount = 0 Then
            MsgBox ("请选择对象, 再调用此宏")
            Exit Sub
        Else
            r = MsgBox("你已选择" + Str(pageCount) + "页幻灯片, 要把所有选择的幻灯片页内的组的字体都设置吗?", vbOKCancel)
            If r = vbCancel Then
                Exit Sub
            End If
            
            For i = 1 To pageCount
                DoEvents
                Dim shapes1 As shapes
                Set shapes1 = slides(i).shapes
                shapeCount = shapes1.Count
                
                For j = 1 To shapeCount
                    Dim shape1 As Shape
                    Set shape1 = shapes1(j)
                    With shapes1(j)
                        If .Type = msoAutoShape Or .Type = msoPlaceholder Or .Type = msoTextBox Then
                            With .TextFrame.TextRange.Font
                                If ChangeFontName <> "" Then
                                    .Name = ChangeFontName
                                End If
                                
                                If ChangeFontSize > 0 Then
                                    .Size = ChangeFontSize
                                End If
                            End With
                        End If
                    End With
                Next j
            Next i
        End If
    ElseIf selType = ppSelectionText Then
        Dim textR As TextRange
        Set textR = selection.TextRange
        If textR.Count = 0 Then
            With textR.Parent.TextRange.Font
                If ChangeFontName <> "" Then
                    .Name = ChangeFontName
                End If
                
                If ChangeFontSize > 0 Then
                    .Size = ChangeFontSize
                End If
            End With
        End If

        With textR.Font
            If ChangeFontName <> "" Then
                .Name = ChangeFontName
            End If
            
            If ChangeFontSize > 0 Then
                .Size = ChangeFontSize
            End If
        End With
    End If
End Sub

  评论这张
 
阅读(408)| 评论(0)
推荐 转载

历史上的今天

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017