Powerpoint中VBA编程技巧

.Application 对象 
该对象代表 PowerPoint 应用程序，通过该对象可访问 PowerPoint 中的其他所有对象。 
 
(1)Active 属性：返回指定窗格是否被激活。 
 
(2)ActivePresentation 属性：返回 Presentation 对象，代表活动窗口中打开的演示文稿。 
 
(3)ActiveWindow 属性：返回 DocumentWindow 对象，代表当前文档窗口。 
 
(4)Presentations 属性：返回 Presentations 集合，代表所有打开的演示文稿。 
 
(5)SlideShowWindows 属性：返回 SlideShowWindows 集合，代表所有打开的幻灯片放映窗
口。 
 
(6)Quit 方法：用于退出 PowerPoint 程序。 
 
2.DocumentWindow 对象 
 
该对象代表文档窗口。使用“Windows(index) ”语法可返回 DocumentWindow 对象。 
 
(1)ActivePane 属性：返回 Pane 对象，代表文档窗口中的活动窗格。 
 
(2)Panes 属性：返回 Panes 集合，代表文档窗口中的所有窗格。 
 
(3)ViewType 属性：返回指定的文档窗口内的视图类型。[NextPage] 
 
3.Presentation 对象 
 
该对象代表演示文稿，通过“Presentations(index)”语法可返回 Presentation 对象。 
 
(1)BuiltInDocumentProperties 属性：返回 DocumentProperties 集合，代表演示文稿的所有文
档属性。 
 
(2)ColorSchemes 属性：返回 ColorSchemes 集合，代表演示文稿的配色方案。 
 
(3)PageSetup 属性：返回 PageSetup 对象，用于控制演示文稿的幻灯片页面设置属性。 
 
(4)SlideMaster 属性：返回幻灯片母版对象。 
 
(5)SlideShowSettings 属性：返回 SlideShowSettings 对象，代表演示文稿的幻灯片放映设置。  
 
(6)SlideShowWindow 属性：返回幻灯片放映窗口对象。 
 
(7)AddTitleMaster 方法：为演示文稿添加标题母版。 
 
 
 
(8)ApplyTemplate 方法：对演示文稿应用设计模板。 
 
4.SlideShowWindow 对象 
 
该对象代表幻灯片放映窗口。 
 
IsFullScreen 属性：用于设置是否全屏显示幻灯片放映窗口。[NextPage] 
 
5.Master 对象 
 
该对象代表幻灯片母版、标题母版、讲义母版或备注母版。 
 
TextStyles 属性：为幻灯片母版返回 TextStyles 集合，代表标题文本、正文文本和默认文本。  
 
6.Slide 对象 
 
该对象代表幻灯片。 
 
(1)SlideID 属性：返回幻灯片的唯一标识符。 
 
(2)SlideIndex 属性：返回幻灯片在 Slides 集合中的索引号。 
 
7.SlideShowView 对象 
 
该对象代表幻灯片放映窗口中的视图。 
 
(1)AcceleratorsEnabled 属性：用于设置是否允许在幻灯片放映时使用快捷键。 
 
(2)CurrentShowPosition 属性：返回当前幻灯片在放映中的位置。 
 
(3)DrawLine 方法：在指定幻灯片放映视图中绘制直线。 
 
(4)EraseDrawing 方法：用于清除通过 DrawLine 方法或绘图笔工具在放映中绘制的直线。 
 
(5)GotoSlide 方法：用于切换指定幻灯片。
powerpoint 学习笔记： http://www.rdpslides.com/pptlive/index.html

标签： <无>

代码片段(2) [全屏查看所有代码]

1. [代码]Powerpoint中VBA编程技巧     跳至 [1] [2] [全屏预览]

0001	Sub PowerPointBasics_1()

0002	' PowerPoint 的对象模型 Ojbect Model (OM)模型导航

0003	' 每个东东在 PowerPoint 中都是某个类型的对象

0004	' 想操作好 PowerPoint，你就要和对象打交道 有些对象是另外一些对象的集合。

0005	' 对象具有属性 – 用来描述对象的东东

0006	' 对象具有方法 – 对象可以做或你可以对他做什么

0007	' 对象模型就是所有 PowerPoint 对象自成一个体系的集合

0008	' 就像一个倒置的树图

0009	' 按 F2 浏览查看对象

0010	' 数的最顶层是应用对象（Application）

0011	' 就是 PowerPoint 本身

0012	' 应用对象有他的属性

0013	Debug.Print Application.Name

0014	' 用 Debug.Print 代替 MsgBox 能节省一点时间

0015	' 我们就不需要点击对话框的“确定”按钮

0016	' Debug.Print 的结果输出在 VB 编辑器环境中的立即窗口中

0017	' 如果它没有显示，通过点击菜单“视图”/“立即窗口”或者按 Ctrl+G 来显示

0018	' .Presentations 属性返回当前打开演示文档的一个集合

0019	' 我们通过“点”提示来调用它的功能

0020	Debug.Print Application.Presentations.Count

0021	' 我们可以指定一个特定的对象

0022

0023	Debug.Print Application.Presentations(1).Name

0024

0025

0026

0027	' 所以说 PowerPoint (即 application 对象) 包含 Presentations 对象

0028

0029	' Presentations 包含 Slides 对象

0030

0031	' Slides 包含 Shapes 对象，如 rectangles 和 circles。

0032

0033	' 所以我们可以自然的这样写:

0034

0035	Debug.Print Application.ActivePresentation.Slides(2).Shapes.Count

0036

0037

0038

0039	' 但是这么长的引用有些令人乏味

0040

0041	' 另一种形式对我们来说更容易一些同时也会让 PowerPoint 处理的更快一些

0042

0043	' 使用 With 关键字来引用你用的对象..

0044

0045	With ActivePresentation.Slides(2).Shapes(2)

0046

0047	' 这样你可以直接引用他的下级功能

0048

0049

0050

0051	Debug.Print .Name

0052

0053	Debug.Print .Height

0054

0055	Debug.Print .Width

0056

0057	' 最后用 End With 关键字来表明引用完毕

0058

0059

End With

0060

0061

0062

0063	' 我们也可以嵌套着使用

0064

0065	With ActivePresentation.Slides(2).Shapes(2)

0066

0067	Debug.Print .Name

0068

0069	With .TextFrame.TextRange

0070

0071	Debug.Print .Text

0072

0073	Debug.Print .Font.Name

0074

0075

End With

0076

0077

End With

0078

0079

0080

0081

End Sub

0082

0083

0084

0085

0086

0087	Sub PowerPointBasics_2()

0088

0089	' 控制当前选中的对象

0090

0091

0092

0093

' 显示对象的名字

0094

0095

0096

0097	With ActiveWindow.Selection.ShapeRange(1)

0098

0099	Debug.Print .Name

0100

0101

End With

0102

0103

0104

0105	' 更改名字并移动他:

0106

0107	With ActiveWindow.Selection.ShapeRange(1)

0108

0109	' 命名对象非常有用

0110

0111	.Name = "My favorite shape"

0112

0113	.Left = .Left + 72  ' 72 像素即 1 英寸

0114

0115

End With

0116

0117

0118

0119

End Sub

0120

0121

0122

0123	Sub PowerPointBasics_3()

0124

0125	' 控制一个已命名的对象

0126

0127	' 如果你知道一个对象的名字

0128

0129	' 你就可以直接控制他

0130

0131	' 不需要繁琐的调用了。

0132

0133

0134

0135	With ActivePresentation.Slides(2).Shapes("My favorite shape")

0136

0137	.Top = .Top - 72

0138

0139

End With

0140

0141

0142

0143

0144

0145	' 每页幻灯片也可以有名字

0146

0147	With ActivePresentation.Slides(2)

0148

0149	.Name = "My favorite slide"

0150

0151

End With

0152

0153

0154

0155	' 无论我们移动他到那个地方，名字不变

0156

0157	' 这样我们就可以方便的操作啦

0158

0159	With ActivePresentation.Slides("My favorite slide").Shapes("My favorite shape")

0160

0161	.Height = .Height * 2

0162

0163

End With

0164

0165

0166

0167

End Sub

0168

0169

0170

0171	Sub PowerPointBasics_4()

0172

0173

' 对象的引用

0174

0175

0176

0177	' 可以通过变量来保持对对象的引用

0178

0179	' 可能会有些难于理解，不过不用担心

0180

0181	' 参照实例很容易理解的。

0182

0183

0184

0185	' 先看下面的例子：

0186

0187

0188

0189

0190

0191	' 定义一个变量为某个类型

0192

0193	Dim oShape As Shape

0194

0195

0196

0197	' 让他指向某个特定的对象

0198

0199	Set oShape = ActivePresentation.Slides("My favorite slide").Shapes("My favorite shape")

0200

0201	' 注意我们使用已命名的对象。

0202

0203

0204

0205	' 从现在开始，我们就可以把 oShape 认作为我们命名的那个对象。

0206

0207	Debug.Print oShape.TextFrame.TextRange.Text

0208

0209	oShape.TextFrame.TextRange.Font.Color.RGB = RGB(255, 0, 0)

0210

0211	' 直到我们删除这个变量，都可以认为他就是我们命名的那个对象。

0212

0213

0214

0215	Set oShape = Nothing

0216

0217

0218

0219

End Sub

0220

0221

0222

0223	Sub PowerPointBasics_5()

0224

0225	' 遍历所有的幻灯片

0226

0227

' 便利所有的对象

0228

0229

0230

0231	' So far, we haven't done anything you couldn't do

0232

0233

0234

0235	' with your mouse, and do it more easily at that.

0236

0237	' One more little lesson, then the real fun starts.

0238

0239

0240

0241	Dim x As Long   ' we'll use X as a counter

0242

0243	' OK, I said always to give variables meaningful names

0244

0245	' But for little "throwaway" jobs like this, programmers often

0246

0247	' use x, y, and the like

0248

0249

0250

0251	' Let's do something with every slide in the presentation

0252

0253	For x = 1 To ActivePresentation.Slides.Count

0254

0255	Debug.Print ActivePresentation.Slides(x).Name

0256

0257

Next x

0258

0259

0260

0261	' Or with every shape on one of the slides

0262

0263	' Since x is a "junk" variable, we'll just re-use it here

0264

0265	' And we'll use the With syntax to save some typing

0266

0267	With ActivePresentation.Slides(3)

0268

0269	For x = 1 To .Shapes.Count

0270

0271	Debug.Print .Shapes(x).Name

0272

0273

Next x

0274

0275	End With  ' ActivePresentation.Slides(3)

0276

0277

0278

0279

0280

0281

End Sub

0282

0283

0284

0285	Sub PowerPointBasics_6()

0286

0287

' 处理异常错误

0288

0289

0290

0291	' You can trust computer users to do one thing and one thing only:

0292

0293	'           The Unexpected

0294

0295	' You can trust computers to do pretty much the same

0296

0297

0298

0299	' That's where error handling comes in

0300

0301

0302

0303	' What do you think will happen when I run this code?

0304

0305	With ActivePresentation.Slides(42)

0306

0307	MsgBox ("Steve, you moron, there IS no slide 42!")

0308

0309

End With

0310

0311

0312

0313

End Sub

0314

0315

0316

0317	Sub PowerPointBasics_6a()

0318

0319	' Error Handling Continued

0320

0321

0322

0323	' Let's protect our code against boneheaded Steves

0324

0325

0326

0327	' If he does something that provokes an error, deal with it gracefully

0328

0329	On Error GoTo ErrorHandler

0330

0331

0332

0333	With ActivePresentation.Slides(42)

0334

0335	MsgBox ("Steve, you moron, there IS no slide 42!")

0336

0337

End With

0338

0339

0340

0341	' Words with a : at the end are "labels"

0342

0343	' and can be the destination of a "GoTo" command

0344

0345	' Using GoTo is considered Very Bad Form except in error handlers

0346

0347

0348

0349	' If we got here without error we need to quit before we hit the error

0350

0351	' handling code so ...

0352

0353	NormalExit:

0354

0355

Exit Sub

0356

0357

0358

0359	ErrorHandler:

0360

0361	MsgBox ("Error: " & Err.Number & vbCrLf & Err.Description)

0362

0363	' resume next

0364

0365	' exit sub

0366

0367	Resume NormalExit

0368

0369

0370

0371

0372

0373

End Sub

0374

0375

0376

0377	Option Explicit

0378

0379	Public strText As String

0380

0381	Public strOption As String

0382

0383

0384

0385	Sub Forms_1()

0386

0387	' Creating/Showing/Unloading a form

0388

0389

0390

0391	' Forms are a more sophisticated way of getting user input than

0392

0393	' simple InputBox commands

0394

0395

0396

0397	' For example:

0398

0399	frmMyForm1.Show

0400

0401

0402

0403	' now the user has dismissed the form

0404

0405	' let's see what they entered

0406

0407

0408

0409	Debug.Print frmMyForm1.TextBox1.Text

0410

0411

0412

0413	If frmMyForm1.OptionButton1.Value = True Then

0414

0415	Debug.Print "Yes"

0416

0417

0418

0419

End If

0420

0421	If frmMyForm1.OptionButton2.Value = True Then

0422

0423	Debug.Print "Chocolate"

0424

0425

End If

0426

0427	If frmMyForm1.OptionButton3.Value = True Then

0428

0429	Debug.Print "Teal"

0430

0431

End If

0432

0433

0434

0435	' we're done with the form so unload it

0436

0437	Unload frmMyForm1

0438

0439

0440

0441	' But what if we want to make the form data available until much later?

0442

0443	' And wouldn't it make more sense to keep all the form's logic

0444

0445	' in the form itself?

0446

0447

0448

0449

End Sub

0450

0451

0452

0453	Sub Forms_2()

0454

0455	' This uses a form with the logic built in

0456

0457	' Note that we had to declare a few PUBLIC variables

0458

0459	' so the form could get at them

0460

0461

0462

0463

0464

0465	frmMyForm2.Show

0466

0467

0468

0469	' we're done with the form so unload it

0470

0471	Unload frmMyForm2

0472

0473

0474

0475	' let's see what they entered - our variables still have the values

0476

0477	' the form code assigned them:

0478

0479	Debug.Print strText

0480

0481	Debug.Print strOption

0482

0483

0484

0485	' CODE RE-USE

0486

0487	' We can export the form to a file and import it into other projects

0488

0489

0490

0491

End Sub

0492

0493

0494

0495	This is the code from the Animation Tricks section of the seminar (modAnimationTricks)

0496

0497

0498

0499

0500

0501	Option Explicit

0502

0503

0504

0505	' This tells VBA how to call on the Windows API Sleep function

0506

0507	' This function puts our VBA code to sleep for X milliseconds

0508

0509

0510

0511	' (thousandths of a second) then lets it wake up after that

0512

0513	' Unlike other ways of killing time, this doesn't hog computer cycles

0514

0515	Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

0516

0517

0518

0519	Sub xYouClicked(oSh As Shape)

0520

0521	Dim oShThought As Shape

0522

0523	Set oShThought = oSh.Parent.Shapes("Thought")

0524

0525

0526

0527	' Make the thought balloon visible

0528

0529	oShThought.Visible = True

0530

0531	' Move it to just to the right of the clicked shape

0532

0533	oShThought.Left = oSh.Left + oSh.Width

0534

0535	' Position it vertically just above the clicked shape

0536

0537	oShThought.Top = oSh.Top - oShThought.Height

0538

0539

0540

0541	Select Case UCase(oSh.Name)

0542

0543	Case Is = "EENIE"

0544

0545	oShThought.TextFrame.TextRange.Text = "Pest!"

0546

0547	Case Is = "MEENIE"

0548

0549	oShThought.TextFrame.TextRange.Text = "This is annoying!"

0550

0551	Case Is = "MINIE"

0552

0553	oShThought.TextFrame.TextRange.Text = "This is REALLY annoying!!"

0554

0555

0556

0557	Case Is = "MOE"

0558

0559	oShThought.Visible = False

0560

0561	oSh.Parent.Shapes("STOP").Visible = True

0562

0563	End Select

0564

0565

0566

0567

End Sub

0568

0569

0570

0571	Sub yYouClicked(oSh As Shape)

0572

0573	' This time we'll use tags to make it easier to maintain

0574

0575

0576

0577	Dim oShThought As Shape

0578

0579	Set oShThought = oSh.Parent.Shapes("Thought")

0580

0581

0582

0583	' Make the thought balloon visible and move it next to the

0584

0585	' shape the user just clicked

0586

0587	oShThought.Visible = True

0588

0589	oShThought.Left = oSh.Left + oSh.Width

0590

0591	oShThought.Top = oSh.Top - oShThought.Height

0592

0593

0594

0595	' Use tags to pick up the text

0596

0597	oShThought.TextFrame.TextRange.Text = oSh.Tags("Thought")

0598

0599

0600

0601

0602

0603

End Sub

0604

0605

0606

0607	Sub AddATag()

0608

0609	' A little macro to add a tag to the selected shape

0610

0611	Dim strTag As String

0612

0613

0614

0615	' Our old buddy InputBox gets the tag text ...

0616

0617	strTag = InputBox("Type the text for the thought balloon", "What is the shape thinking?")

0618

0619

0620

0621	' Instead of forcing user to enter something, we'll just quit

0622

0623

' if not

0624

0625	If strTag = "" Then

0626

0627

Exit Sub

0628

0629

End If

0630

0631

0632

0633	' Must have entered something, so tag the shape with it

0634

0635	With ActiveWindow.Selection.ShapeRange(1)

0636

0637	.Tags.Add "Thought", strTag

0638

0639

End With

0640

0641

End Sub

0642

0643

0644

0645	Sub YouClicked(oSh As Shape)

0646

0647

0648

0649	' And now we'll add a WinAPI Sleep call to make it even smoother

0650

0651

0652

0653	Dim oShThought As Shape

0654

0655	Set oShThought = oSh.Parent.Shapes("Thought")

0656

0657

0658

0659	' Use tags to pick up the text

0660

0661	oShThought.TextFrame.TextRange.Text = oSh.Tags("Thought")

0662

0663

0664

0665	' Make the thought balloon visible and move it next to the

0666

0667	' shape the user just clicked

0668

0669	oShThought.Left = oSh.Left + oSh.Width

0670

0671	oShThought.Top = oSh.Top - oShThought.Height

0672

0673	oShThought.Visible = True

0674

0675

0676

0677	' give the system a little time to redraw

0678

0679

DoEvents

0680

0681

0682

0683	' Now wait a second (1000 milliseconds to be precise) ...

0684

0685	Sleep 1000

0686

0687	' and make it invisible again

0688

0689	oShThought.Visible = False

0690

0691

0692

0693

0694

0695

End Sub

0696

0697

0698

0699

0700

0701	Sub Reset()

0702

0703	' Re-bait our little trap so it's ready for the next

0704

0705	' unwary user

0706

0707	ActivePresentation.Slides("AnimationTricks").Shapes("STOP").Visible = False

0708

0709	ActivePresentation.Slides("AnimationTricks").Shapes("Thought").Visible = False

0710

0711

End Sub

0712

0713

0714

0715

0716

0717	This is the code from the Mass Quantities section of the seminar (modMassQuantities) that deals

0718	with automating actions across many slides or many presentations.

0719

0720

0721

0722

0723

0724	Option Explicit

0725

0726

0727

0728	Sub GreenToRed()

0729

0730	' Object variables for Slides and Shapes

0731

0732	Dim oSh As Shape

0733

0734	Dim oSl As Slide

0735

0736

0737

0738	For Each oSl In ActivePresentation.Slides

0739

0740

0741

0742	For Each oSh In oSl.Shapes

0743

0744	If oSh.Fill.ForeColor.RGB = RGB(0, 255, 0) Then

0745

0746	oSh.Fill.ForeColor.RGB = RGB(255, 0, 0)

0747

0748

End If

0749

0750

Next oSh

0751

0752

Next oSl

0753

0754

0755

0756

End Sub

0757

0758

0759

0760	Sub FolderFull()

0761

0762	' For each presentation in a folder that matches our specifications

0763

0764	'   - open the file

0765

0766	'   - call another subroutine that does something to it

0767

0768	'   - save the file

0769

0770	'   - close the file

0771

0772

0773

0774	Dim strCurrentFile As String    ' variable to hold a single file name

0775

0776	Dim strFileSpec As String       ' variable to hold our file spec

0777

0778	' give it a value that works for my computer:

0779

0780	strFileSpec

0781

=

0782	"C:\Documents

0783

and

0784	Settings\Stephen

0785	Rindsberg\Desktop\PPTLive\Automation\LotsOfFiles\*.ppt"

0786

0787

0788

0789

0790

0791	' get the first file that matches our specification

0792

0793	strCurrentFile = Dir$(strFileSpec)

0794

0795

0796

0797	' don't do anything if we didn't find any matching files

0798

0799	' but if we did, keep processing files until we don't find any more

0800

0801	While Len(strCurrentFile) > 0

0802

0803	' open the presentation

0804

0805	Presentations.Open (strCurrentFile)

0806

0807

0808

0809	' by changing this next line to call a different subroutine

0810

0811	' you can have this same code do other tasks

0812

0813	Debug.Print ActivePresentation.Name

0814

0815

0816

0817	' call the Green to Red macro to process the file

0818

0819	Call GreenToRed

0820

0821

0822

0823	' save the file under a new name with FIXED_ at the beginning

0824

0825	ActivePresentation.SaveAs (ActivePresentation.Path & "\" _

0826

0827	& "Fixed_" _

0828

0829	& ActivePresentation.Name)

0830

0831

0832

0833	' close it

0834

0835

0836

0837	ActivePresentation.Close

0838

0839	' and get the next file that matches our specification

0840

0841	' if you don't supply a new file spec, Dir$ returns the next

0842

0843	' file that matches the previously supplied specification

0844

0845	strCurrentFile = Dir$

0846

0847

Wend

0848

0849

0850

0851	' Note: Don't use Dir in code that's called from within a loop

0852

0853	' that uses Dir - only one "Dir" can be "active" at a time.

0854

0855	' In production code, it's best to keep it in a very short loop or

0856

0857	' to collect file names in a short loop then process them after

0858

0859	' Arrays are useful for this

0860

0861

0862

0863

End Sub

0864

0865

0866

0867	Misc. Example code from the seminar (modMiscExamples)

0868

0869

0870

0871

0872

0873

0874

0875	Option Explicit

0876

0877

0878

0879	Sub FolderFullFromArray()

0880

0881

0882

0883	' Uses array to collect filenames for processing

0884

0885	' This is more reliable than processing the files within a loop

0886

0887	' that includes DIR

0888

0889

0890

0891	Dim rayFileNames() As String

0892

0893	Dim strCurrentFile As String    ' variable to hold a single file name

0894

0895	Dim strFileSpec As String       ' variable to hold our file spec

0896

0897	' give it a value that works for my computer:

0898

0899	strFileSpec

0900

=

0901	"C:\Documents

0902

and

0903	Settings\Stephen

0904	Rindsberg\Desktop\PPTLive\Automation\LotsOfFiles\*.ppt"

0905

0906

0907

0908	' Redimension the array to 1 element

0909

0910	ReDim rayFileNames(1 To 1) As String

0911

0912

0913

0914	' get the first file that matches our specification

0915

0916	strCurrentFile = Dir$(strFileSpec)

0917

0918

0919

0920	' don't do anything if we didn't find any matching files

0921

0922	' but if we did, keep processing files until we don't find any more

0923

0924	While Len(strCurrentFile) > 0

0925

0926	' Add it to the array

0927

0928	rayFileNames(UBound(rayFileNames)) = strCurrentFile

0929

0930	strCurrentFile = Dir

0931

0932

0933

0934	' redimension the array

0935

0936	ReDim Preserve rayFileNames(1 To UBound(rayFileNames) + 1) As String

0937

0938

Wend

0939

0940

0941

0942	' If there were no files, the array has one element

0943

0944	' If it has more than one element, the last element is blank

0945

0946	If UBound(rayFileNames) > 1 Then

0947

0948	' lop off the last, empty element

0949

0950	ReDim Preserve rayFileNames(1 To UBound(rayFileNames) - 1) As String

0951

0952

Else

0953

0954	' no files found

0955

0956

Exit Sub

0957

0958

End If

0959

0960

0961

0962	' If we got this far, we have files to process in the array so

0963

0964	Dim x As Long

0965

0966

0967

0968	For x = 1 To UBound(rayFileNames)

0969

0970

0971

0972	' open the presentation

0973

0974	Presentations.Open (rayFileNames(x))

0975

0976	Debug.Print ActivePresentation.Name

0977

0978

0979

0980

0981

0982	' call the Green to Red macro to process the file

0983

0984	Call GreenToRed

0985

0986

0987

0988	' save the file under a new name with FIXED_ at the beginning

0989

0990	ActivePresentation.SaveAs (ActivePresentation.Path & "\" _

0991

0992	& "Fixed_" _

0993

0994	& ActivePresentation.Name)

0995

0996

0997

0998	' close it

0999

1000	ActivePresentation.Close

1001

1002

Next x

1003

1004

1005

1006

End Sub

1007

1008

1009

1010	This is the code from the Macro Recorder demonstration

1011

1012

1013

1014

1015

1016	The Macro Recorder is handy for little quickie macros and especially for learning how

1017	PowerPoint's object model works, but it doesn't produce code that's very useful as is.

1018

1019

1020

1021

1022

1023

1024

1025	This demonstrates how you can make the recorder produce more useful code and how you can

1026	take what you've learned from it and tweak it into something more generally useful.

1027

1028

1029

1030

1031

1032	Suppose the corporate colors have just changed from green to red. You've got dozens or hundreds

1033	of presentations with the fills set to the old green and need to change them all. Fast.

1034

1035

1036

1037

1038

1039	You open one in PPT and record a macro while you select a shape and change its color from green

1040

to red.

1041

1042	Here's what you end up with:

1043

1044

1045

1046

1047

1048	Sub Macro1()

1049

1050

1051

1052	ActiveWindow.Selection.SlideRange.Shapes("Rectangle 5").Select

1053

1054	With ActiveWindow.Selection.ShapeRange

1055

1056	.Fill.Visible = msoTrue

1057

1058	.Fill.ForeColor.RGB = RGB(255, 0, 102)

1059

1060	.Fill.Solid

1061

1062

End With

1063

1064	ActivePresentation.ExtraColors.Add RGB(Red:=255, Green:=0, Blue:=102)

1065

1066

1067

1068

End Sub

1069

1070

1071

1072

1073

1074	This has a few problems:

1075

1076

1077

1078	It only works IF there's a shape named "Rectangle 5" on the current slide

1079

1080	It will only change a shape by that name, no other

1081

1082	It changes things we may not WANT changed (.Fill.Solid, .Fill.Visible)

1083

1084	It adds extra colors to the PPT palette (.ExtraColors)

1085

1086

1087

1088	In short, it solves the problem of changing ONE shape on ONE slide from green to red. And that's

1089	it. And it creates other potential problems in the process.

1090

1091

1092

1093

1094

1095	But it did show us how to change a shape's color in PowerPoint VBA, so it's not totally useless.

1096

1097

1098

1099

1100

1101	Let's see if we can get it to do something more general.

1102

1103	Select the green rectangle first, THEN record a macro while changing it to red:

1104

1105

1106

1107

1108

1109	Sub Macro2()

1110

1111

1112

1113	With ActiveWindow.Selection.ShapeRange

1114

1115

1116

1117	.Fill.ForeColor.RGB = RGB(255, 0, 102)

1118

1119	.Fill.Visible = msoTrue

1120

1121	.Fill.Solid

1122

1123

End With

1124

1125

1126

1127

End Sub

1128

1129

1130

1131	That's better. A lot better. It works on any selected shape and in fact it works on multiple selected

1132

shapes.

1133

1134	It still sets a few extra properties but we can comment those out.

1135

1136	Now you can select all the shapes on each slide, run this macro and ...

1137

1138

1139

1140

1141

1142	No. Don't do that. It'll change all the green selected shapes to red, true. Also all the blue ones and

1143	purple ones and so on. ALL the selected shapes.

1144

1145

1146

1147

1148

1149	So you still have to go from slide to slide selecting all (and ONLY) the green shapes, then running

1150	the macro again and again.

1151

1152

1153

1154

1155

1156	Enough of this. Here's how you and the other VBA Pros really do this kind of stuff:

1157

1158

1159

1160

1161

1162

1163

1164	Sub GreenToRed()

1165

1166

1167

1168	Dim oSh As Shape

1169

1170	Dim oSl As Slide

1171

1172

1173

1174	' Look at each slide in the current presentation:

1175

1176	For Each oSl In ActivePresentation.Slides

1177

1178

1179

1180	' Look at each shape on each slide:

1181

1182	For Each oSh In oSl.Shapes

1183

1184

1185

1186	' IF the shape's .Fill.ForeColor.RGB = pure green:

1187

1188	If oSh.Fill.ForeColor.RGB = RGB(0, 255, 0) Then

1189

1190

1191

1192	' Change it to red

1193

1194	oSh.Fill.ForeColor.RGB = RGB(255, 0, 0)

1195

1196

1197

1198

End If

1199

1200

1201

1202

Next oSh

1203

1204

1205

1206

Next oSl

1207

1208

1209

1210

1211

1212

End Sub

1213

1214

1215

1216	In less time than it takes you to get your finger off the mouse button, that will change thousands of

1217	shapes on hundreds of slides from green to red. And it only touches the shapes that are the exact

1218	shade of green we've targeted, no other colors.

1219

1220	Is it safe to touch the text?

1221	Not all shapes can have text. If you try to access a text property of one of these, PowerPoint errors

1222

out.

1223	In addition, some shapes created by PowerPoint 97 can be corrupted to the point where, though

1224	they have the ability to hold text, they cause errors if you try to check for the text.

1225

1226

1227	This is kind of a safety check function. It tests the various things that might cause errors and

1228	returns True if none of them actually cause errors.

1229

1230

1231	Public Function IsSafeToTouchText(pShape As Shape) As Boolean

1232

1233	On Error GoTo Errorhandler

1234

1235	If pShape.HasTextFrame Then

1236	If pShape.TextFrame.HasText Then

1237	' Errors here if it's a bogus shape:

1238	If Len(pShape.TextFrame.TextRange.text) > 0 Then

1239	' it's safe to touch it

1240	IsSafeToTouchText = True

1241	Exit Function

1242	End If ' Length > 0

1243	End If ' HasText

1244	End If ' HasTextFrame

1245

1246	Normal_Exit:

1247	IsSafeToTouchText = False

1248	Exit Function

1249

1250	Errorhandler:

1251	IsSafeToTouchText = False

1252	Exit Function

1253

1254

1255

1256	End Function

1257

1258

1259	What's the path to the PPA (add-in) file?

1260

1261	If your add-in requires additional files, you'll probably keep them in the same folder as the add-in

1262

itself.

1263

1264

1265

1266

1267

1268	Ah, but where's that? A user might install an add-in from anywhere on the local hard drive or even

1269	from a network drive, so you can't be certain where the add-in and its associated files are. At least

1270	not without this:

1271

1272

1273

1274

1275

1276	Public Function PPAPath(AddinName as String) As String

1277

1278	' Returns the path to the named add-in if found, null if not

1279

1280	' Dependencies:  SlashTerminate (listed below, explained later)

1281

1282

1283

1284	Dim x As Integer

1285

1286	PPAPath = ""

1287

1288

1289

1290	For x = 1 To Application.AddIns.count

1291

1292	If UCase(Application.AddIns(x).Name) = UCase(AddinName) Then

1293

1294	' we found it, so

1295

1296	PPAPath = Application.AddIns(x).path & GetPathSeparator

1297

1298	' no need to check any other addins

1299

1300

1301

1302	Exit Function

1303

1304

End If

1305

1306

Next x

1307

1308

1309

1310	' So we can run it from a PPT in the IDE instead of a PPA:

1311

1312	If PPAPath = "" Then

1313

1314	PPAPath = SlashTerminate(ActivePresentation.path)

1315

1316

End If

1317

1318

1319

1320	End Function

1321

1322

1323

1324	Function SlashTerminate(sPath as String) as String

1325

1326	' Returns a string terminated with a path separator character

1327

1328	' Works on PC or Mac

1329

1330

1331

1332	Dim PathSep As String

1333

1334	#If Mac Then

1335

1336	PathSep = ":"

1337

1338

#Else

1339

1340	PathSep = "\"

1341

1342

#End If

1343

1344

1345

1346

1347

1348	' Is the rightmost character a backslash?

1349

1350	If Right$(sPath,1) <> PathSep Then

1351

1352	' No; add a backslash

1353

1354	SlashTerminate = sPath & PathSep

1355

1356

Else

1357

1358	SlashTerminate = sPath

1359

1360

End If

1361

1362

1363

1364	End Function

2. [代码][ASP/Basic]代码     跳至 [1] [2] [全屏预览]

view source

print?

01	ActivePresentation.Slides(2).Shapes.Placeholders(1).Delete

02	ActivePresentation.Save

03	ActivePresentation.NewWindow

04

05	创建ppt文档。增加一张slide

06	With Presentations.Add

07	.Slides.Add Index:=1, Layout:=ppLayoutTitle

08	.SaveAs "Sample"

09

End With

10

11

打开ppt文档。

12	Presentations.Open FileName:="c:\My Documents\pres1.ppt", _

13	ReadOnly:=msoTrue

14

15

创建保存ppt

16	Sub AddAndSave(pptPres As Presentation)

17	pptPres.Slides.Add 1, 1

18	pptPres.SaveAs pptPres.Application.Path & "\Added Slide"

19

End Sub

20

21	Slide标题删除与恢复

22	ActivePresentation.Slides(2).Shapes.Placeholders(1).Delete

23	Application.ActivePresentation.Slides(2) _

24	.Shapes.AddPlaceholder ppPlaceholderTitle

25

26	当前演示文稿中添加一张幻灯片，为该幻灯片标题（幻灯片第一个占位符）和副标题添加文本

27	Set myDocument = ActivePresentation.Slides(1)

28	With ActivePresentation.Slides _

29	.Add(1, ppLayoutTitle).Shapes.Placeholders

30	.Item(1).TextFrame.TextRange.Text = "This is the title text"

31	.Item(2).TextFrame.TextRange.Text = "This is subtitle text"

32

End With

33

34	将主题或设计模式应用于当前ppt

35	ActivePresentation.ApplyTheme

36

37	若要在幻灯片中添加形状并返回一个代表新建形状的 Shape 对象，请使用 Shapes 集合的下列方法之一：AddCallout 、AddComment 、AddConnector 、AddCurve 、AddLabel 、AddLine 、AddMediaObject 、AddOLEObject 、AddPicture 、AddPlaceholder 、AddPolyline 、AddShape 、AddTable 、AddTextbox 、AddTextEffect 、AddTitle 。

38

39	使用 Shapes.Title 返回代表幻灯片标题的 Shape 对象。使用 Shapes.AddTitle 在无标题的幻灯片中添加标题并返回代表新建标题的 Shape 对象。

40	使用Shapes.Placeholders(index) 返回一个代表占位符的 Shape 对象，其中 index 是占位符的索引号。

41	如果没有改变过幻灯片中形状的排列顺序，则以下三个语句是等价的（假设第一张幻灯片有标题）。

42	ActivePresentation.Slides(1).Shapes.Title _

43	.TextFrame.TextRange.Font.Italic = True

44	ActivePresentation.Slides(1).Shapes.Placeholders(1) _

45	.TextFrame.TextRange.Font.Italic = True

46	ActivePresentation.Slides(1).Shapes(1).TextFrame _

47	.TextRange.Font.Italic = True

48

49	使用 HasTextFrame 属性判断形状是否含有文本框，并使用 HasText 属性判断该文本框是否包含文本，如以下示例所示。

50	Set myDocument = ActivePresentation.Slides(1)

51	For Each s In myDocument.Shapes

52	If s.HasTextFrame Then

53	With s.TextFrame

54	If .HasText Then MsgBox .TextRange.Text

55

End With

56

End If

57

Next

58

59	使用 TextFrame 对象的 TextRange 属性返回任意指定形状的 TextRange 对象。使用 Text 属性返回 TextRange 对象中的文本字符串。以下示例向 myDocument 中添加一个矩形并设置其包含的文本

60	Set myDocument = ActivePresentation.Slides(1)

61	myDocument.Shapes.AddShape(msoShapeRectangle, 0, 0, 250, 140) _

62	.TextFrame.TextRange.Text = "Here is some test text"

63

64	使用 HasTextFrame 属性判断形状是否含有文本框，然后使用 HasText 属性判断该文本框是否包含文本。

65	使用 Selection 对象的 TextRange 属性返回当前选定的文字。以下示例将选定内容复制到剪贴板。

66	ActiveWindow.Selection.TextRange.Copy

67

68	使用下列方法之一可返回 TextRange 对象中的部分文本：Characters、Lines、Paragraphs、Runs、Sentences 或 Words。

69	使用 Find 和 Replace 方法可查找和替换文本范围内的文本。

70	使用下列方法之一可向 TextRange 对象中插入字符：InsertAfter、InsertBefore、InsertDateTime、InsertSlideNumber 或 InsertSymbol。

71

72	本示例创建活动演示文稿中第一张幻灯片的一个副本，然后设置新幻灯片的背景阴影和标题文本。新幻灯片将作为演示文稿的第二张幻灯片。

73	Set newSlide = ActivePresentation.Slides(1).Duplicate

74	With newSlide

75	.Background.Fill.PresetGradient msoGradientVertical, _

76	1, msoGradientGold

77	.Shapes.Title.TextFrame.TextRange _

78	.Text = "Second Quarter Earnings"

79

End With

80

81

增加回车换行控制符

82	Chr(13) & Chr(10)