|
|
Option Explicit
Sub FolderFullFromArray()'使用数组来收集文件名进行处理
'这比在循环中使用dir处理文件名更加可靠
Dim rayFileNames()As String
Dim strCurrentFile As String'代表文件名的变量
Dim strFileSpec As String'代表扩展名的变量
'给出一个在计算机能正常应用的路径值
strFileSpec="C:\Documentsand
Rindsberg\Desktop\PPTLive\Automation\LotsOfFiles\*.ppt"
ReDimrayFileNames(1 To 1)As String'重定义数组维数为1
strCurrentFile=Dir$(strFileSpec)'获取符合我们要求的第一个文件
WhileLen(strCurrentFile)>0
rayFileNames(UBound(rayFileNames))=strCurrentFile'添加到数组
strCurrentFile=Dir'重定义数组维数
ReDimPreserve rayFileNames(1 To UBound(rayFileNames)+1)As St
Wend
'如果没有文件了，数组只有一个元素，如果还有更多的元素，则最后一个为空
IfUBound(rayFileNames)>1 Then'去掉最后一个空元素
ReDim Preserve rayFileNames(1 To UBound(rayFileNames)-1)As St
Else
'没有找到文件
Exit Sub
EndIf'如果运行到了这里，则我们已经收集好了文件名数组
Dim x As Long
Forx=1 To UBound(rayFileNames)
Presentations.Open(rayFileNames(x)) '打开ppt文件
Debug.Print ActivePresentation.Name
Call GreenToRed'调用过程函数
ActivePresentation.SaveAs(ActivePresentation.Path&"\"&"Fixed_"& ActivePresentation.Name)
ActivePresentation.Close
Nextx
End Sub
这是从宏录制的演示代码，录制宏是对于新手很容易掌握和学习ppt对象模型是如何运作的，但是其不会产生很有用的代码。这表明要获取非常有用的代码，还需要自己去对其进行修改和整理。假设共同的颜色都由绿色转为了红色，有数百个这样填充的ppt需要设置为原来的绿色，首先，你打开一个ppt，选择一个图形，将其颜色由绿色变为红色，并录制了一个宏，到这里结束：
Sub Macro1()
ActiveWindow.Selection.SlideRange.Shapes("Rectangle5").Select
WithActiveWindow.Selection.ShapeRange
.Fill.Visible=msoTrue
.Fill.ForeColor.RGB=RGB(255,0,102)
.Fill.Solid
EndWith
ActivePresentation.ExtraColors.AddRGB(Red:=255,Green:=0,Blue:=102)
End Sub
但是存在一些问题：它仅仅适用于当前的一张有一个名字为"Rectangle 5"的图形的ppt，仅仅改变这个图形，没有其他的改变如透明度填充，可见性等。而且为ppt调色板增加了额外的颜色。总之，只是改变了当前页ppt的当前的图形的颜色从绿变红。仅仅如此。而且在这个过程中还创设了潜在的一些问题。然而其却向我们展示了如何用VBA代码去改变一个图形的颜色，所以也并不是全无用处。让我们看看能否让其变成更加通用的东西。选择绿色的图形，再录制一个宏，将其改变为红色。
Sub Macro2()
WithActiveWindow.Selection.ShapeRange.Fill.ForeColor.RGB=RGB(255,0,102)
.Fill.Visible=msoTrue
.Fill.Solid
EndWith
End Sub
这个更好了，好多了，在任何选定的图形，而且事实上在多个选定的图形上都适用。它仍旧设置了一些额外的我们不需要的属性，不过我们可以将这些东西都注释掉。你可以在任何一页ppt上选择所有图形来运行这个宏，不过，最好不要那样做，因为其不仅会将绿色，还会将蓝色、紫色等其他颜色的图形统统变为红色。因此你需要逐张ppt遍历，去选定所有绿色的图形并一遍又一遍的运行这个宏。这些就够了。下面就是你和其他的VBA高手所做的东西：
Sub GreenToRed()
Dim oSh As Shape
Dim oSl As Slide
ForEach oSl In ActivePresentation.Slides'在当前ppt查找每张幻灯片:
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
NextoSl
End Sub
哈哈，弹指之间，数百个ppt中数千的图形的颜色实现了由绿色变为了红色。而且仅仅是改变了我们目标中的绿色图形，而不改变其他的颜色的图形。对带有文本的情况是安全的吗？并非所有的图形内都有文本，如果你试图去访问其中的一个文本属性，ppt将会弹出错误。此外，ppt97创建的文本会出现冲突，虽然它们有保留文本的能力，但当你试图去检查其中的文本时会出现错误。下面是个安全检查函数，用于测试所有可能引发错误的情况，如果没有任何错误，则返回值为Ture。
Public Function IsSafeToTouchText(pShape AsShape)As Boolean
On Error GoTo Errorhandler
IfpShape.HasTextFrame Then
If pShape.TextFrame.HasText Then
If Len(pShape.TextFrame.TextRange.text)>0 Then'若果是个假的形状这里将出现错误
IsSafeToTouchText=True'安全的情况
Exit Function
End If '长度>0
End If '存在文本
EndIf '存在文本框
Normal_Exit:
IsSafeToTouchText=False
ExitFunction
Errorhandler:
IsSafeToTouchText=False
ExitFunction
End Function
加载宏PPA文件的路径是什么？如果你需加载额外的加载行，你可能需要将它们放进加载宏的文件夹。但是它在哪里呢？用户可能会从本地磁盘或网络驱动器去安装加载项，因此你不确定加载项和相关的文件到底在哪里。至少不是没有这种情况：
Public Function PPAPath(AddinName asString)As String
返回找到的加载项的路径，斜杠结尾，没有找到则返回空
Dim x AsInteger
PPAPath=""
For x=1 ToApplication.AddIns.count
If UCase(Application.AddIns(x).Name)=UCase(AddinName)Then
PPAPath=Application.AddIns(x).path&GetPathSeparator'我们找到了
'不需要去检查其他的加载项
Exit Function
End If
Nextx
'因此我们从ppt的IDE中运行，而非从PPA中:
IfPPAPath=""Then
PPAPath=SlashTerminate(ActivePresentation.path)
EndIf
End Function
到此算是翻译完了。讲的都是比较简单的ppt的遍历的用法。其实个人认为，ppt的精髓——动画部分的VBA才真正是麻烦的和高级的东西。不过作为入门，这个应该是很有帮助的。 |
|
