Powerpoint中VBA编程技巧

概述Powerpoint中VBA编程技巧

下面是内存溢出 jb51.cc 通过网络收集整理的代码片段。

内存溢出小编现在分享给大家，也给大家做个参考。

Sub PowerPointBasics_1()     ' PowerPoint 的对象模型 Ojbect Model (OM)模型导航     ' 每个东东在 PowerPoint 中都是某个类型的对象     ' 想 *** 作好 PowerPoint，你就要和对象打交道 有些对象是另外一些对象的集合。     ' 对象具有属性 – 用来描述对象的东东     ' 对象具有方法 – 对象可以做或你可以对他做什么     ' 对象模型就是所有 PowerPoint 对象自成一个体系的集合     ' 就像一个倒置的树图      ' 按 F2 浏览查看对象      ' 数的最顶层是应用对象（Application）     ' 就是 PowerPoint 本身     ' 应用对象有他的属性     DeBUG.Print Application.name      ' 用 DeBUG.Print 代替 MsgBox 能节省一点时间      ' 我们就不需要点击对话框的“确定”按钮      ' DeBUG.Print 的结果输出在 VB 编辑器环境中的立即窗口中      ' 如果它没有显示，通过点击菜单“视图”/“立即窗口”或者按 Ctrl+G 来显示      ' .Presentations 属性返回当前打开演示文档的一个集合      ' 我们通过“点”提示来调用它的功能      DeBUG.Print Application.Presentations.Count      ' 我们可以指定一个特定的对象      DeBUG.Print Application.Presentations(1).name         ' 所以说 PowerPoint (即 application 对象) 包含 Presentations 对象      ' Presentations 包含 SlIDes 对象      ' SlIDes 包含 Shapes 对象，如 rectangles 和 circles。      ' 所以我们可以自然的这样写:      DeBUG.Print Application.ActivePresentation.SlIDes(2).Shapes.Count         ' 但是这么长的引用有些令人乏味      ' 另一种形式对我们来说更容易一些同时也会让 PowerPoint 处理的更快一些      ' 使用 With 关键字来引用你用的对象..      With ActivePresentation.SlIDes(2).Shapes(2)          ' 这样你可以直接引用他的下级功能            DeBUG.Print .name          DeBUG.Print .Height          DeBUG.Print .WIDth      ' 最后用 End With 关键字来表明引用完毕      End With         ' 我们也可以嵌套着使用      With ActivePresentation.SlIDes(2).Shapes(2)          DeBUG.Print .name          With .TextFrame.TextRange              DeBUG.Print .Text              DeBUG.Print .Font.name          End With      End With     End Sub        Sub PowerPointBasics_2()      ' 控制当前选中的对象         ' 显示对象的名字        With ActiveWindow.Selection.ShapeRange(1)          DeBUG.Print .name      End With         ' 更改名字并移动他:      With ActiveWindow.Selection.ShapeRange(1)          ' 命名对象非常有用          .name = "My favorite shape"          .left = .left + 72  ' 72 像素即 1 英寸      End With     End Sub     Sub PowerPointBasics_3()      ' 控制一个已命名的对象      ' 如果你知道一个对象的名字      ' 你就可以直接控制他      ' 不需要繁琐的调用了。         With ActivePresentation.SlIDes(2).Shapes("My favorite shape")          .top = .top - 72      End With           ' 每页幻灯片也可以有名字      With ActivePresentation.SlIDes(2)          .name = "My favorite slIDe"      End With         ' 无论我们移动他到那个地方，名字不变      ' 这样我们就可以方便的 *** 作啦      With ActivePresentation.SlIDes("My favorite slIDe").Shapes("My favorite shape")          .Height = .Height * 2      End With     End Sub     Sub PowerPointBasics_4()      ' 对象的引用         ' 可以通过变量来保持对对象的引用      ' 可能会有些难于理解，不过不用担心      ' 参照实例很容易理解的。         ' 先看下面的例子：           ' 定义一个变量为某个类型      Dim oShape As Shape         ' 让他指向某个特定的对象      Set oShape = ActivePresentation.SlIDes("My favorite slIDe").Shapes("My favorite shape")      ' 注意我们使用已命名的对象。         ' 从现在开始，我们就可以把 oShape 认作为我们命名的那个对象。      DeBUG.Print oShape.TextFrame.TextRange.Text      oShape.TextFrame.TextRange.Font.color.RGB = RGB(255,0)      ' 直到我们删除这个变量，都可以认为他就是我们命名的那个对象。         Set oShape = nothing     End Sub     Sub PowerPointBasics_5()      ' 遍历所有的幻灯片      ' 便利所有的对象         ' So far,we haven't done anything you Couldn't do        ' with your mouse,and do it more easily at that.      ' One more little lesson,then the real fun starts.         Dim x As Long   ' we'll use X as a counter      ' OK,I saID always to give variables meaningful names      ' But for little "throwaway" jobs like this,programmers often      ' use x,y,and the like         ' Let's do something with every slIDe in the presentation      For x = 1 To ActivePresentation.SlIDes.Count          DeBUG.Print ActivePresentation.SlIDes(x).name      Next x         ' Or with every shape on one of the slIDes      ' Since x is a "junk" variable,we'll just re-use it here      ' And we'll use the With Syntax to save some tyPing      With ActivePresentation.SlIDes(3)          For x = 1 To .Shapes.Count              DeBUG.Print .Shapes(x).name          Next x      End With  ' ActivePresentation.SlIDes(3)       End Sub     Sub PowerPointBasics_6()      ' 处理异常错误         ' You can trust computer users to do one thing and one thing only:      '           The Unexpected      ' You can trust computers to do pretty much the same         ' That's where error handling comes in         ' What do you think will happen when I run this code?      With ActivePresentation.SlIDes(42)          MsgBox ("Steve,you moron,there IS no slIDe 42!")      End With     End Sub     Sub PowerPointBasics_6a()      ' Error Handling Continued         ' Let's protect our code against boneheaded Steves        ' If he does something that provokes an error,deal with it gracefully      On Error GoTo ErrorHandler         With ActivePresentation.SlIDes(42)          MsgBox ("Steve,there IS no slIDe 42!")      End With     ' Words with a : at the end are "labels"  ' and can be the destination of a "GoTo" command  ' Using GoTo is consIDered Very Bad Form except in error handlers     ' If we got here without error we need to quit before we hit the error  ' handling code so ...  normalExit:      Exit Sub     ErrorHandler:      MsgBox ("Error: " & Err.Number & vbCrLf & Err.Description)      ' resume next      ' exit sub      Resume normalExit       End Sub     Option Explicit   Public strText As String   Public strOption As String      Sub Forms_1()       ' Creating/Showing/Unloading a form          ' Forms are a more sophisticated way of getting user @R_403_5983@ than       ' simple @R_403_5983@Box commands          ' For example:       frmMyForm1.Show          ' Now the user has dismissed the form       ' let's see what they entered          DeBUG.Print frmMyForm1.TextBox1.Text          If frmMyForm1.Optionbutton1.Value = True Then           DeBUG.Print "Yes"         End If       If frmMyForm1.Optionbutton2.Value = True Then           DeBUG.Print "Chocolate"       End If       If frmMyForm1.Optionbutton3.Value = True Then           DeBUG.Print "teal"       End If          ' we're done with the form so unload it       Unload frmMyForm1          ' But what if we want to make the form data available until much later?       ' And wouldn't it make more sense to keep all the form's logic       ' in the form itself?      End Sub      Sub Forms_2()       ' This uses a form with the logic built in       ' Note that we had to declare a few PUBliC variables       ' so the form Could get at them            frmMyForm2.Show          ' we're done with the form so unload it       Unload frmMyForm2          ' let's see what they entered - our variables still have the values       ' the form code assigned them:       DeBUG.Print strText       DeBUG.Print strOption          ' CODE RE-USE       ' We can export the form to a file and import it into other projects      End Sub     This is the code from the Animation Tricks section of the seminar (modAnimationTricks)         Option Explicit      ' This tells VBA how to call on the windows API Sleep function   ' This function puts our VBA code to sleep for X milliseconds     ' (thousandths of a second) then lets it wake up after that   ' Unlike other ways of killing time,this doesn't hog computer cycles   Private Declare Sub Sleep lib "kernel32" (ByVal DWMilliseconds As Long)      Sub xYouClicked(oSh As Shape)       Dim oShThought As Shape       Set oShThought = oSh.Parent.Shapes("Thought")          ' Make the thought balloon visible       oShThought.Visible = True       ' Move it to just to the right of the clicked shape       oShThought.left = oSh.left + oSh.WIDth       ' position it vertically just above the clicked shape       oShThought.top = oSh.top - oShThought.Height          Select Case UCase(oSh.name)           Case Is = "EENIE"               oShThought.TextFrame.TextRange.Text = "pest!"           Case Is = "MEENIE"               oShThought.TextFrame.TextRange.Text = "This is annoying!"           Case Is = "MINIE"               oShThought.TextFrame.TextRange.Text = "This is REALLY annoying!!"             Case Is = "MOE"               oShThought.Visible = False               oSh.Parent.Shapes("Stop").Visible = True       End Select      End Sub      Sub yYouClicked(oSh As Shape)       ' This time we'll use Tags to make it easIEr to maintain          Dim oShThought As Shape       Set oShThought = oSh.Parent.Shapes("Thought")          ' Make the thought balloon visible and move it next to the       ' shape the user just clicked       oShThought.Visible = True       oShThought.left = oSh.left + oSh.WIDth       oShThought.top = oSh.top - oShThought.Height          ' Use Tags to pick up the text       oShThought.TextFrame.TextRange.Text = oSh.Tags("Thought")        End Sub      Sub AddATag()       ' A little macro to add a tag to the selected shape       Dim strTag As String          ' Our old buddy @R_403_5983@Box gets the tag text ...       strTag = @R_403_5983@Box("Type the text for the thought balloon","What is the shape thinking?")          ' Instead of forcing user to enter something,we'll just quit       ' if not       If strTag = "" Then           Exit Sub       End If          ' Must have entered something,so tag the shape with it       With ActiveWindow.Selection.ShapeRange(1)           .Tags.Add "Thought",strTag       End With   End Sub      Sub YouClicked(oSh As Shape)         ' And Now we'll add a WinAPI Sleep call to make it even smoother          Dim oShThought As Shape       Set oShThought = oSh.Parent.Shapes("Thought")          ' Use Tags to pick up the text       oShThought.TextFrame.TextRange.Text = oSh.Tags("Thought")          ' Make the thought balloon visible and move it next to the       ' shape the user just clicked       oShThought.left = oSh.left + oSh.WIDth       oShThought.top = oSh.top - oShThought.Height       oShThought.Visible = True          ' give the system a little time to redraw       DoEvents          ' Now wait a second (1000 milliseconds to be precise) ...       Sleep 1000       ' and make it invisible again       oShThought.Visible = False        End Sub         Sub reset()       ' Re-bait our little trap so it's ready for the next       ' unwary user       ActivePresentation.SlIDes("AnimationTricks").Shapes("Stop").Visible = False       ActivePresentation.SlIDes("AnimationTricks").Shapes("Thought").Visible = False   End Sub        This is the code from the Mass QuantitIEs section of the seminar (modMassQuantitIEs) that deals with automating actions across many slIDes or many presentations.         Option Explicit      Sub GreenToRed()       ' Object variables for SlIDes and Shapes       Dim oSh As Shape       Dim oSl As SlIDe          For Each oSl In ActivePresentation.SlIDes             For Each oSh In oSl.Shapes               If oSh.Fill.Forecolor.RGB = RGB(0,255,0) Then                   oSh.Fill.Forecolor.RGB = RGB(255,0)               End If           Next oSh       Next oSl      End Sub      Sub FolderFull()       ' For each presentation in a folder that matches our specifications       '   - open the file       '   - call another subroutine that does something to it       '   - save the file       '   - close the file          Dim strCurrentfile As String    ' variable to hold a single file name       Dim strfileSpec As String       ' variable to hold our file spec       ' give it a value that works for my computer:       strfileSpec = "C:\documents and Settings\Stephen Rindsberg\Desktop\PPTlive\automation\LotsOffiles\*.ppt"            ' get the first file that matches our specification       strCurrentfile = Dir$(strfileSpec)          ' don't do anything if we dIDn't find any matching files       ' but if we dID,keep processing files until we don't find any more       While Len(strCurrentfile) > 0           ' open the presentation           Presentations.Open (strCurrentfile)              ' by changing this next line to call a different subroutine           ' you can have this same code do other tasks           DeBUG.Print ActivePresentation.name              ' call the Green to Red macro to process the file           Call GreenToRed              ' save the file under a new name with FIXED_ at the beginning           ActivePresentation.SaveAs (ActivePresentation.Path & "\" _               & "Fixed_" _               & ActivePresentation.name)              ' close it             ActivePresentation.Close           ' and get the next file that matches our specification           ' if you don't supply a new file spec,Dir$ returns the next           ' file that matches the prevIoUsly supplIEd specification           strCurrentfile = Dir$       Wend          ' Note: Don't use Dir in code that's called from within a loop       ' that uses Dir - only one "Dir" can be "active" at a time.       ' In production code,it's best to keep it in a very short loop or       ' to collect file names in a short loop then process them after       ' Arrays are useful for this      End Sub     Misc. Example code from the seminar (modMiscExamples)            Option Explicit      Sub FolderFullFromArray()         ' Uses array to collect filenames for processing       ' This is more reliable than processing the files within a loop       ' that includes DIR          Dim rayfilenames() As String       Dim strCurrentfile As String    ' variable to hold a single file name       Dim strfileSpec As String       ' variable to hold our file spec       ' give it a value that works for my computer:       strfileSpec = "C:\documents and Settings\Stephen Rindsberg\Desktop\PPTlive\automation\LotsOffiles\*.ppt"          ' Redimension the array to 1 element       ReDim rayfilenames(1 To 1) As String          ' get the first file that matches our specification       strCurrentfile = Dir$(strfileSpec)          ' don't do anything if we dIDn't find any matching files       ' but if we dID,keep processing files until we don't find any more       While Len(strCurrentfile) > 0           ' Add it to the array           rayfilenames(UBound(rayfilenames)) = strCurrentfile           strCurrentfile = Dir             ' redimension the array           ReDim Preserve rayfilenames(1 To UBound(rayfilenames) + 1) As String       Wend          ' If there were no files,the array has one element       ' If it has more than one element,the last element is blank       If UBound(rayfilenames) > 1 Then           ' lop off the last,empty element           ReDim Preserve rayfilenames(1 To UBound(rayfilenames) - 1) As String       Else           ' no files found           Exit Sub       End If          ' If we got this far,we have files to process in the array so       Dim x As Long          For x = 1 To UBound(rayfilenames)              ' open the presentation           Presentations.Open (rayfilenames(x))           DeBUG.Print ActivePresentation.name                ' call the Green to Red macro to process the file           Call GreenToRed              ' save the file under a new name with FIXED_ at the beginning           ActivePresentation.SaveAs (ActivePresentation.Path & "\" _               & "Fixed_" _               & ActivePresentation.name)              ' close it           ActivePresentation.Close       Next x      End Sub     This is the code from the Macro Recorder demonstration         The Macro Recorder is handy for little quickIE macros and especially for learning how PowerPoint's object model works,but it doesn't produce code that's very useful as is.           This demonstrates how you can make the recorder produce more useful code and how you can take what you've learned from it and tweak it into something more generally useful.         Suppose the corporate colors have just changed from green to red. You've got doZens or hundreds of presentations with the fills set to the old green and need to change them all. Fast.         You open one in PPT and record a macro while you select a shape and change its color from green to red.   Here's what you end up with:         Sub Macro1()          ActiveWindow.Selection.SlIDeRange.Shapes("Rectangle 5").Select       With ActiveWindow.Selection.ShapeRange           .Fill.Visible = msoTrue           .Fill.Forecolor.RGB = RGB(255,102)           .Fill.solID       End With       ActivePresentation.Extracolors.Add RGB(Red:=255,Green:=0,Blue:=102)      End Sub        This has a few problems:      It only works IF there's a shape named "Rectangle 5" on the current slIDe    It will only change a shape by that name,no other    It changes things we may not WANT changed (.Fill.solID,.Fill.Visible)    It adds extra colors to the PPT palette (.Extracolors)       In short,it solves the problem of changing ONE shape on ONE slIDe from green to red. And that's it. And it creates other potential problems in the process.         But it dID show us how to change a shape's color in PowerPoint VBA,so it's not totally useless.         Let's see if we can get it to do something more general.   Select the green rectangle first,THEN record a macro while changing it to red:         Sub Macro2()          With ActiveWindow.Selection.ShapeRange             .Fill.Forecolor.RGB = RGB(255,102)           .Fill.Visible = msoTrue           .Fill.solID       End With      End Sub      That's better. A lot better. It works on any selected shape and in fact it works on multiple selected shapes.   It still sets a few extra propertIEs but we can comment those out.   Now you can select all the shapes on each slIDe,run this macro and ...         No. Don't do that. It'll change all the green selected shapes to red,true. Also all the blue ones and purple ones and so on. ALL the selected shapes.         So you still have to go from slIDe to slIDe selecting all (and ONLY) the green shapes,then running the macro again and again.         Enough of this. Here's how you and the other VBA Pros really do this kind of stuff:           Sub GreenToRed()          Dim oSh As Shape       Dim oSl As SlIDe          ' Look at each slIDe in the current presentation:       For Each oSl In ActivePresentation.SlIDes              ' Look at each shape on each slIDe:           For Each oSh In oSl.Shapes                  ' IF the shape's .Fill.Forecolor.RGB = pure green:               If oSh.Fill.Forecolor.RGB = RGB(0,0) Then                      ' Change it to red                   oSh.Fill.Forecolor.RGB = RGB(255,0)                  End If              Next oSh          Next oSl        End Sub      In less time than it takes you to get your finger off the mouse button,that will change thousands of shapes on hundreds of slIDes from green to red. And it only touches the shapes that are the exact shade of green we've targeted,no other colors.   Is it safe to touch the text? Not all shapes can have text. If you try to access a text property of one of these,PowerPoint errors out. In addition,some shapes created by PowerPoint 97 can be corrupted to the point where,though they have the ability to hold text,they cause errors if you try to check for the text.   This is kind of a safety check function. It tests the varIoUs things that might cause errors and returns True if none of them actually cause errors.   Public Function IsSafetotouchText(pShape As Shape) As Boolean   On Error GoTo Errorhandler   If pShape.HasTextFrame Then   If pShape.TextFrame.HasText Then    ' Errors here if it's a bogus shape:     If Len(pShape.TextFrame.TextRange.text) > 0 Then     ' it's safe to touch it     IsSafetotouchText = True     Exit Function    End If ' Length > 0   End If ' HasText  End If ' HasTextFrame  normal_Exit:  IsSafetotouchText = False  Exit Function  Errorhandler:  IsSafetotouchText = False  Exit Function    End Function   What's the path to the PPA (add-in) file?   If your add-in requires additional files,you'll probably keep them in the same folder as the add-in itself.         Ah,but where's that? A user might install an add-in from anywhere on the local hard drive or even from a network drive,so you can't be certain where the add-in and its associated files are. At least not without this:         Public Function PPAPath(Addinname as String) As String   ' Returns the path to the named add-in if found,null if not   ' DependencIEs:  SlashTerminate (Listed below,explained later)             Dim x As Integer          PPAPath = ""             For x = 1 To Application.AddIns.count                 If UCase(Application.AddIns(x).name) = UCase(Addinname) Then                        ' we found it,so                        PPAPath = Application.AddIns(x).path & GetPathSeparator                        ' no need to check any other addins                          Exit Function                 End If          Next x             ' So we can run it from a PPT in the IDE instead of a PPA:          If PPAPath = "" Then                 PPAPath = SlashTerminate(ActivePresentation.path)          End If      End Function      Function SlashTerminate(sPath as String) as String   ' Returns a string terminated with a path separator character   ' Works on PC or Mac             Dim PathSep As String          #If Mac Then                 PathSep = ":"          #Else                 PathSep = "\"          #End If               ' Is the rightmost character a backslash?          If Right$(sPath,1) <> PathSep Then                 ' No; add a backslash                 SlashTerminate = sPath & PathSep          Else                 SlashTerminate = sPath          End If      End Function  

以上是内存溢出(jb51.cc)为你收集整理的全部代码内容，希望文章能够帮你解决所遇到的程序开发问题。

如果觉得内存溢出网站内容还不错，欢迎将内存溢出网站推荐给程序员好友。

总结

以上是内存溢出为你收集整理的Powerpoint中VBA编程技巧全部内容，希望文章能够帮你解决Powerpoint中VBA编程技巧所遇到的程序开发问题。

如果觉得内存溢出网站内容还不错，欢迎将内存溢出网站推荐给程序员好友。