【源码】Access代码全文搜索和替换PPT中的文字

tmtony

如果我们需要对所有PPT里形状里的文字和内容进行搜索和替换时，以下这个通用函数就非常有用了。其实VBA代码是相通的。只要在Office环境中，VBA可实现很多自动化工作。

1. ' --------------------------------------------------------------------------------
   
2. ' Copyright ©1999-2015, Shyam Pillai, All Rights Reserved.
   
3. ' --------------------------------------------------------------------------------
   
4. ' You are free to use this code within your own applications, add-ins,
   
5. ' documents etc but you are expressly forbidden from selling or
   
6. ' otherwise distributing this source code without prior consent.
   
7. ' This includes both posting free demo projects made from this
   
8. ' code as well as reproducing the code in text or html format.
   
9. ' --------------------------------------------------------------------------------
   
10. Sub GlobalFindAndReplace()
    
11. Dim oPres As Presentation
    
12. Dim oSld As Slide
    
13. Dim oShp As Shape
    
14. Dim FindWhat As String
    
15. Dim ReplaceWith As String
    
16. 
    
17. FindWhat = "Like"
    
18. ReplaceWith = "Not Like"
    
19. For Each oPres In Application.Presentations
    
20.      For Each oSld In oPres.Slides
    
21.         For Each oShp In oSld.Shapes
    
22.             Call ReplaceText(oShp, FindWhat, ReplaceWith)
    
23.         Next oShp
    
24.     Next oSld
    
25. Next oPres
    
26. End Sub
    
27. 
    
28. Sub ReplaceText(oShp As Object, FindString As String, ReplaceString As String)
    
29. Dim oTxtRng As TextRange
    
30. Dim oTmpRng As TextRange
    
31. Dim I As Integer
    
32. Dim iRows As Integer
    
33. Dim iCols As Integer
    
34. Dim oShpTmp As Shape
    
35. 
    
36. ' Always include the 'On error resume next' statement below when you are working with text range object.
    
37. ' I know of at least one PowerPoint bug where it will error out - when an image has been dragged/pasted
    
38. ' into a text box. In such a case, both HasTextFrame and HasText properties will return TRUE but PowerPoint
    
39. ' will throw an error when you try to retrieve the text.
    
40. On Error Resume Next
    
41. Select Case oShp.Type
    
42. Case 19 'msoTable
    
43.     For iRows = 1 To oShp.Table.Rows.Count
    
44.         For icol = 1 To oShp.Table.Rows(iRows).Cells.Count
    
45.             Set oTxtRng = oShp.Table.Rows(iRows).Cells(iCol).Shape.TextFrame.TextRange
    
46.             Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
    
47.                                   Replacewhat:=ReplaceString, WholeWords:=True)
    
48.             Do While Not oTmpRng Is Nothing
    
49.             Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
    
50.                                 Replacewhat:=ReplaceString, _
    
51.                                 After:=oTmpRng.Start + oTmpRng.Length, _
    
52.                                 WholeWords:=True)
    
53.             Loop
    
54.         Next
    
55.     Next
    
56. Case msoGroup 'Groups may contain shapes with text, so look within it
    
57.     For I = 1 To oShp.GroupItems.Count
    
58.         Call ReplaceText(oShp.GroupItems(I), FindString, ReplaceString)
    
59.     Next I
    
60. Case 21 ' msoDiagram
    
61.     For I = 1 To oShp.Diagram.Nodes.Count
    
62.         Call ReplaceText(oShp.Diagram.Nodes(I).TextShape, FindString,     ReplaceString)
    
63.     Next I
    
64. Case Else
    
65.     If oShp.HasTextFrame Then
    
66.         If oShp.TextFrame.HasText Then
    
67.             Set oTxtRng = oShp.TextFrame.TextRange
    
68.             Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
    
69.                 Replacewhat:=ReplaceString, WholeWords:=True)
    
70.             Do While Not oTmpRng Is Nothing
    
71.                 Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _
    
72.                             Replacewhat:=ReplaceString, _
    
73.                             After:=oTmpRng.Start + oTmpRng.Length, _
    
74.                             WholeWords:=True)
    
75.             Loop
    
76.        End If
    
77.     End If
    
78. End Select
    
79. End Sub

复制代码

摘自 Shyam Pillai 文章

wuwu200222

学习