本文提供了一段使用VBA宏在PowerPoint2003中批量修改公式颜色的代码实例，包括如何针对不同类型的形状进行递归处理，并详细解释了代码逻辑与应用方法。
在PowerPoint 2003下运行通过，使用时只要随便新建一个宏，把它自动生成的代码全删去，粘贴上面这段代码。然后运行 ReColor 这个宏就可以了。(小遗憾，还不知道如何设定自选图形的属性，知道告诉我！）
' The macro to excute
Sub ReColor()
Dim sld As Slide
Dim sh As Shape
For Each sld In ActivePresentation.Slides
For Each sh In sld.Shapes
Call ReColorSH(sh)
Next
Next
End Sub
Function ReColorSH(sh As Shape)
Dim ssh As Shape
If sh.Type = msoGroup Then ' when the shape itself is a group
For Each ssh In sh.GroupItems
Call ReColorSH(ssh) ' the recursion
Next
'改变公式中文字的颜色为黑色，不知如何设置为其他颜色
ElseIf sh.Type = msoEmbeddedOLEObject Then ' recolor the equation
oShp.PictureFormat.ColorType = msoPictureBlackAndWhite
oShp.PictureFormat.Brightness = 0
oShp.PictureFormat.Contrast = 1
oShp.Fill.Visible = msoFalse
'改变文本框中文字的颜色，可自己设定
ElseIf sh.HasTextFrame Then
' /* 当前幻灯片中的当前形状包含文本. */
If sh.TextFrame.HasText Then
' 引用文本框架中的文本.
Set trng = sh.TextFrame.TextRange
' /* 遍历文本框架中的每一个字符. */
For i = 1 To trng.Characters.Count
' 这里请自行修改为原来的颜色值 (白色).
'If trng.Characters(i).Font.Color = vbWhite Then
' 这里请自行修改为要替换的颜色值 (黑色).
trng.Characters(i).Font.Color = vbBlack
'End If
Next
End If
End If
End Function也不是全部原创，订正错误后，集三个而成。一：http://blog.sina.com.cn/s/blog_5e44963d0100t4fd.html （细心的可以发现我纠正了他的一个错误说法,并且不能改变公式中文字的颜色）
二：http://zhidao.baidu.com/question/542242004.html（这个不能修改组合对象的，而“一”可以，我的当然也可以啦）
三：http://blog.sina.com.cn/s/blog_546e0c1f0100uqtx.html（特定用于改变公式中文字的颜色）
都附上吧，省得到处找或者失效：
一：
ppt批量修改图片中公式的颜色 VBA（转）
(2011-06-12 13:51:11）
在学校老师的课件大都是ppt,所以不得不和微软的东西打交道 。
我们有一位老师，他的课件中的公式都被他重新着色成了黄色，这样上课时配着蓝色背景，既醒目又看着舒服。可是我们打印的时候才发现，即使打印时颜色选成纯黑白，那写公式也照样灰灰、浅浅的，几乎看不清。一份幻灯片里有无数的公式，手工修改肯定很累。自己Office水平又比较菜，不知道PowerPoint有什么内置功能可以批量修改公式颜色（有人知道的话，请不吝赐教），幸好以前VB用的还好，就在手册的帮助下，写了一个宏，最终解决了这个问题。不过费尽周折，历时三周（当然，不是全部用来干这个）。
一开始根本不知道解决问题的方向（以下省略走的弯路若干字），后来在浏览Shape对象的属性时发现了有 BlackWhiteMode 这个属性，才知道PowerPoint在纯黑白模式打印时是根据对象的这个属性来决定打印的颜色。这才找到解决问题的方向。
可是接下来问题又来了，老师为了排版，把很多公式与文字及图片组合起来，而且有时还不止一层组合，这样就必须递归遍历来找出其中的公式（如果直接全部打成黑的，很多图片就会变成一团黑，看不清。）递归本来很简单，我写了如下的代码，这也是我后来代码的原型：
' The macro to excute
Sub ReColor
(
)
Dim sld
As Slide
Dim sh
As Shape
For Each sld In ActivePresentation.
Slides
For Each sh In sld.
Shapes
Call ReColorSH
(sh
)
Next
Next
End
Sub
Sub ReColorSH
(sh
As Shape
)
Dim ssh
As Shape
If sh.
Type = msoGroup
Then
' when the shape itself is a group
For Each ssh In sh.
GroupItemsReColorSH
(ssh
)
' the recursion
Next
ElseIf sh.
Type = msoEmbeddedOLEObject
Then
' recolor the equation
If
Left
(sh.
OLEFormat.
ProgID,
8
) =
"Equation"
Thensh.
BlackWhiteMode = msoBlackWhiteBlack
End
If
End
If
End
Sub
但VBA貌似不能传递Shape对象作为参数。所以不得不花费功夫用数组作堆栈并自行模拟递归过程,下面是最终代码：
' VBA cannot pass Shape into a function, so global var is used
Public sh
As Shape
' The macro to excute
Sub ReColor
(
)
Dim sld
As Slide
For Each sld In ActivePresentation.
Slides
For Each sh In sld.
Shapes
Call ReColorSH
Next
Next
End
Sub
Sub ReColorSH
(
)
Dim ip
As
Integer
' point to the top of the i stack
Dim sp
As
Integer
' point to the top of the shape stack
Dim istk
(
)
As
Integer
' the i stack, using dynamic array
Dim sstk
(
)
As Shape
' the Shape stack, using dynamic array
Dim ssize
As
Integer
' the size of both stacksssize =
10
ReDim istk
(ssize
)
ReDim sstk
(ssize
)ip =
0sp =
0
Dim i
As
IntegerL2:
If sh.
Type = msoGroup
Theni =
1L1:
'pushS(sh)sp = sp +
1
If sp > ssize
Thenssize = ssize +
1
ReDim Preserve istk
(ssize
)
ReDim Preserve sstk
(ssize
)
End
If
Set sstk
(sp
) = sh
'----------
'pushI (i)ip = ip +
1istk
(ip
) = i
'----------
Set sh = sh.
GroupItems
(i
)
GoTo L2L3:
'popI(i)i = istk
(ip
)ip = ip -
1
'----------
'popS(sh)
Set sh = sstk
(sp
)sp = sp -
1
'----------
If i < sh.
GroupItems.
Count
Theni = i +
1
GoTo L1
End
If
ElseIf sh.
Type = msoEmbeddedOLEObject
Then
If
Left
(sh.
OLEFormat.
ProgID,
8
) =
"Equation"
Thensh.
BlackWhiteMode = msoBlackWhiteBlack
End
If
End
If
If ip >
0
Then
GoTo L3
End
Sub
在PowerPoint 2003下运行通过。但是在2007中不能使用（个人认为是2007中的颜色控制函数的改变）。
（使用时只要随便新建一个宏，把它自动生成的代码全删去，粘贴上面这段代码。然后运行 ReColor 这个宏就可以了。）
对了，只有在打印的时候把模式选成黑白效果才会显现。幻灯片本身的颜色不会改变。（如果不运行这个宏,即使用黑白打印公式也是浅灰的。）
二：
以下代码可以实现批量替换活动窗口中打开的演示文稿中的所有幻灯片中的文字颜色（具体颜色值请自行修改）：
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub
Demo()
Dim
s
As
Slide
Dim
shp
As
Shape
Dim
trng
As
TextRange
Dim
i
As
Integer
' /* 遍历活动窗口中打开的演示文稿中的幻灯片. */
For
Each
s
In
ActivePresentation.Slides
' /* 遍历当前幻灯片中的形状对象. */
For
Each
shp
In
s.Shapes
' /* 当前幻灯片中的当前形状含有文本框架. */
If
shp.HasTextFrame
Then
' /* 当前幻灯片中的当前形状包含文本. */
If
shp.TextFrame.HasText
Then
' 引用文本框架中的文本.
Set
trng = shp.TextFrame.TextRange
' /* 遍历文本框架中的每一个字符. */
For
i = 1
To
trng.Characters.Count
' 这里请自行修改为原来的颜色值 (浅绿色).
If
trng.Characters(i).Font.Color = vbRed
Then
' 这里请自行修改为要替换的颜色值 (深绿色).
trng.Characters(i).Font.Color = vbBlue
End
If
Next
End
If
End
If
Next
Next
End
Sub
三：
不错的帖子。我也写了一个类似的程序，但是跟你的一样，这个程序只能够把公式的文字转成黑白，不能转成其它颜色，例如蓝色或红色。我需要把公式全部变成红色...
Sub change_text_color()
Dim oSld As Slide
Dim oShp As Shape
Dim oShapes As Shapes
Dim textColor As RGBColor
For Each oSld In ActivePresentation.Slides
Set oShapes = oSld.Shapes
For Each oShp In oShapes
If oShp.Type = 7 Then
oShp.PictureFormat.ColorType = msoPictureBlackAndWhite
oShp.PictureFormat.Brightness = 0
oShp.PictureFormat.Contrast = 1
oShp.Fill.Visible = msoFalse
End If
Next oShp
Next oSld
End Sub
扫一扫
1322
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
