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

徐彩刚的博客

我的站:MathCai.Com

 
 
 

日志

 
 

【转载】[转]ppt用vba  

2012-08-26 17:12:55|  分类: 默认分类 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |
本文转载自冰冻千尺《[转]ppt用vba》
老婆的ppt用vba全部搞定了。。。powerpoint的研究就此收手。
2009年03月22日 21:53
参考了英文教程:很有用的,就翻译了一点,嘻嘻。有空再说(估计就此over了。)发布一下:
http://docs.google.com/Doc?id=dfvhqg8g_38f3ptkddq

[转]ppt用vba - 冰冻千尺 - 冰冻千尺的博客

-------------- 记录当前的显示的页面,可以返回原调用页。
'
Dim oOld As Integer
'
'
Private Sub lbback_Click()
'
    If oOld > 0 Then
        ActivePresentation.SlideShowWindow.View.GotoSlide oOld
    End If
End Sub
Private Sub lbContent_Click()
   'oOld = ActiveWindow.Selection.SlideRange.SlideNumber
   i = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
   If i <> ActivePresentation.Slides("showmark").SlideNumber Then
        oOld = i
    End If
    
   
   ActivePresentation.SlideShowWindow.View.GotoSlide ActivePresentation.Slides("showmark").SlideNumber
  

End Sub
Private Sub Label1_Click()
lbContent_Click
End Sub
Private Sub Label2_Click()
lbback_Click
End Sub
-------------------------------------------------------- 记分和评分页面。
'
Const nGroup As Integer = 4

Dim group(nGroup) As Integer
'
'
'
Private Sub substar(a_idx As Integer)
    If UBound(group) >= a_idx Then
        Debug.Print CStr(a_idx) + "组现在有星星" + CStr(group(a_idx)) + " substract ----- "
        
        
        sName = "star" + CStr(a_idx) + "N" + CStr(group(a_idx))
        
        Debug.Print "-----" + sName
        
        If group(a_idx) > 0 Then
            ActivePresentation.Slides("showmark").Shapes(sName).Delete
            group(a_idx) = group(a_idx) - 1
        Else
            MsgBox "没有星星啦~"
        End If
            
        ActivePresentation.Slides("showmark").Shapes("mark" + CStr(a_idx)).TextFrame.TextRange.Text = CStr(group(a_idx))
    Else
        MsgBox "wrong message , shouldn't prompt this"
    End If
    
End Sub
Private Sub addstar(a_idx As Integer)
    
    Dim x As Integer
    Dim y As Integer
    Dim sepx, sepy As Integer
    
    sepx = 40
    sepy = 40
    
    Select Case a_idx   '不同的加星星的地方
        Case 1
            x = 80
            y = 150
        Case 2
            x = 350
            y = 150
        Case 3
            x = 80
            y = 350
        Case 4
            x = 350
            y = 350
    End Select
    If UBound(group) >= a_idx Then
        Debug.Print CStr(a_idx) + "组现在有星星" + CStr(group(a_idx)) + " add ----- "
        With ActivePresentation.Slides("showmark").Shapes("star").Duplicate
            group(a_idx) = group(a_idx) + 1
            .Name = "star" + CStr(a_idx) + "N" + CStr(group(a_idx))
            
            Debug.Print "-----" + .Name
                        
            
            If group(a_idx) > 15 Then ' 第n行
                .Top = y + sepy * 2
                .Left = x + sepx
            ElseIf group(a_idx) > 10 Then ' 第3行
                .Top = y + sepy * 2
                .Left = x + (group(a_idx) - 10) * sepx
            ElseIf group(a_idx) > 5 Then   ' 第2行
                .Top = y + sepy
                .Left = x + (group(a_idx) - 5) * sepx
            Else                           ' 第1行
                .Top = y
                .Left = x + group(a_idx) * sepx
            End If
            
            ActivePresentation.Slides("showmark").Shapes("mark" + CStr(a_idx)).TextFrame.TextRange.Text = CStr(group(a_idx))
            
            
        End With
    Else
        MsgBox "wrong message , shouldn't prompt this"
    End If
    
End Sub

Private Sub CommandButton2_Click()

End Sub
Private Sub cbadd1_Click()
    '
    For i = 1 To 1
        addstar (1)
    Next
    '
End Sub
Private Sub cbadd2_Click()
    addstar (2)
End Sub
Private Sub cbadd3_Click()
    addstar (3)
End Sub
Private Sub cbadd4_Click()
    addstar (4)
End Sub
Private Sub cbover_Click()
    
    Dim max As Integer
    Dim win As Integer
    Dim tmp As Integer
    Dim wintext As String
    
    
    max = 0
    win = 0
    wintext = ""
    
    For i = 1 To nGroup
        tmp = CInt(ActivePresentation.Slides("showmark").Shapes("mark" + CStr(i)).TextFrame.TextRange.Text)
        If max < tmp Then
            max = tmp
            win = i
        End If
    Next
    
    For i = 1 To nGroup
        If CInt(ActivePresentation.Slides("showmark").Shapes("mark" + CStr(i)).TextFrame.TextRange.Text) = max Then
            If Len(wintext) > 0 Then wintext = wintext + "、"
            wintext = wintext + CStr(i)
        End If
    Next
    
    If win > 0 Then
        ActivePresentation.Slides("showmark").Shapes("winner").TextFrame.TextRange.Text = "winner is " + wintext
    End If
    
End Sub
Private Sub cbreset_Click()
    If MsgBox("确定要重新积分么?", vbOKCancel, "注意") = vbCancel Then
        Exit Sub
    End If
    
    For i = 1 To nGroup
        k = group(i)
        If k < 10 Then k = 30
        
        group(i) = 0
        For j = 1 To k
            On Error Resume Next
            odel = "star" + CStr(i) + "N" + CStr(j)
            Debug.Print "delete -- " + odel
            ActivePresentation.Slides("showmark").Shapes(odel).Delete
        Next
    Next
    
    For i = 1 To 4
        ActivePresentation.Slides("showmark").Shapes("mark" + CStr(i)).TextFrame.TextRange.Text = "0"
    Next
    ActivePresentation.Slides("showmark").Shapes("winner").TextFrame.TextRange.Text = ""
    
End Sub
Private Sub cbsub1_Click()
    substar (1)
End Sub
Private Sub cbsub2_Click()
    substar (2)
End Sub
Private Sub cbsub3_Click()
    substar (3)
End Sub
Private Sub cbsub4_Click()
    substar (4)
End Sub
Private Sub test()
    ' 显示当前选中的对象名称,可以改名用于控制
    MsgBox ActiveWindow.Selection.ShapeRange(1).Name
    'ActiveWindow.Selection.ShapeRange(1).Name = "winner"      ' 定位 posn   markn   showmark   winner
    
    'MsgBox ActiveWindow.Selection.ShapeRange(1).Left
    'MsgBox ActiveWindow.Selection.ShapeRange(1).Top
    
    
    
End Sub
  评论这张
 
阅读(69)| 评论(0)
推荐 转载

历史上的今天

评论

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

页脚

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