在PowerPoint中使用宏实现批量修改公式的打印颜色
在学校老师的课件大都是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.GroupItems
ReColorSH(ssh) ' the recursion
Next
ElseIf sh.Type = msoEmbeddedOLEObject Then ' recolor the equation
If Left(sh.OLEFormat.ProgID, 8) = "Equation" Then
sh.BlackWhiteMode = msoBlackWhiteBlack
End If
End If
End Sub
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.GroupItems
ReColorSH(ssh) ' the recursion
Next
ElseIf sh.Type = msoEmbeddedOLEObject Then ' recolor the equation
If Left(sh.OLEFormat.ProgID, 8) = "Equation" Then
sh.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 stacks
ssize = 10
ReDim istk(ssize)
ReDim sstk(ssize)
ip = 0
sp = 0
Dim i As Integer
L2: If sh.Type = msoGroup Then
i = 1
L1: 'pushS(sh)
sp = sp + 1
If sp > ssize Then
ssize = ssize + 1
ReDim Preserve istk(ssize)
ReDim Preserve sstk(ssize)
End If
Set sstk(sp) = sh
'----------
'pushI (i)
ip = ip + 1
istk(ip) = i
'----------
Set sh = sh.GroupItems(i)
GoTo L2
L3: 'popI(i)
i = istk(ip)
ip = ip - 1
'----------
'popS(sh)
Set sh = sstk(sp)
sp = sp - 1
'----------
If i < sh.GroupItems.Count Then
i = i + 1
GoTo L1
End If
ElseIf sh.Type = msoEmbeddedOLEObject Then
If Left(sh.OLEFormat.ProgID, 8) = "Equation" Then
sh.BlackWhiteMode = msoBlackWhiteBlack
End If
End If
If ip > 0 Then GoTo L3
End Sub
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 stacks
ssize = 10
ReDim istk(ssize)
ReDim sstk(ssize)
ip = 0
sp = 0
Dim i As Integer
L2: If sh.Type = msoGroup Then
i = 1
L1: 'pushS(sh)
sp = sp + 1
If sp > ssize Then
ssize = ssize + 1
ReDim Preserve istk(ssize)
ReDim Preserve sstk(ssize)
End If
Set sstk(sp) = sh
'----------
'pushI (i)
ip = ip + 1
istk(ip) = i
'----------
Set sh = sh.GroupItems(i)
GoTo L2
L3: 'popI(i)
i = istk(ip)
ip = ip - 1
'----------
'popS(sh)
Set sh = sstk(sp)
sp = sp - 1
'----------
If i < sh.GroupItems.Count Then
i = i + 1
GoTo L1
End If
ElseIf sh.Type = msoEmbeddedOLEObject Then
If Left(sh.OLEFormat.ProgID, 8) = "Equation" Then
sh.BlackWhiteMode = msoBlackWhiteBlack
End If
End If
If ip > 0 Then GoTo L3
End Sub
在PowerPoint 2003下运行通过。
（使用时只要随便新建一个宏，把它自动生成的代码全删去，粘贴上面这段代码。然后运行 ReColor 这个宏就可以了。）
对了，只有在打印的时候把模式选成黑白效果才会显现。幻灯片本身的颜色不会改变。（如果不运行这个宏,即使用黑白打印公式也是浅灰的。）
2009年9月25日 02:58
非常之感谢！！
2011年6月05日 10:59
你好，刚试用了一下你提供的代码，运行时出现了错误，提示“对象变量或with块变量未设置”，该怎么解决？谢谢！
2011年6月05日 11:02
问题以解决，不好意思，是我操作错误。谢谢你的方法，碰巧也遇上了同样的问题。万分感谢！
2022年8月10日 01:07
Blue host Webmail lets the individual create their professional and personalized email address. Having a business or personal brand does require a personalized email address, which increases more credibility. The attraction from customers will be more when you use your business related or personal name in the mail instead of using @outlook or @gmail. Bluehost Login There are options under Blue host Webmail that allow users to create personal email without actually creating a website. The Blue host Webmail control panel allows you to create multiple emails with a user-friendly option to access the same.
2022年8月17日 17:25 National Institute of Open Schooling is also known as short name NIOS. NIOS organization that is established in the year of 1989 by ministry of human resources development, NIOS +1 Previous Paper 2023 and it is based of national education policy. This school prepare up of open school learning system has establish its helping hand to the students.
2022年9月06日 21:42
Government of the People’s Republic of Bangladesh, Directorate of Primary Education (DPE), is going to announce PSC Result 2022 in student wide on 30th December 2022 for all divisional Grade 5 exam result with Ebtedayee Result 2022 for annual final terminal examinations, The Primary School Certificate Examination Result 2022 will be announced for both of General and Madhrsah students in division wise to all education board known as Prathomik Somaponi Result 2022. Grade 5 Result Rajshahi BoardThe DPE has successfully conducted the class 5th grade PSC and Ebtedayee Examination tests from 17th to 24th November 2022 under all education boards of Dhaka, Chittagong, Comilla, Rajshahi, Sylhet, Barisal, Jessore, Dinajpur and Madrasah Board, and the DPE Grade-5 exams are successfully conducted at all 7,194 centers across the country.