清华大佬耗费三个月吐血整理的几百G的资源，免费分享！....>>>
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, 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, you moron, 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 input than
' simple InputBox 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 InputBox gets the tag text ...
strTag = InputBox("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, 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, 0, 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, 0, 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, 255, 0) Then
' Change it to red
oSh.Fill.ForeColor.RGB = RGB(255, 0, 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