Office中国论坛/Access中国论坛

标题: 【源码】Access代码全文搜索和替换PPT中的文字 [打印本页]
作者: tmtony    时间: 2015-7-9 09:29
标题: 【源码】Access代码全文搜索和替换PPT中的文字
如果我们需要对所有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

  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

  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

  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    时间: 2020-11-30 14:30
学习



欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/) Powered by Discuz! X3.3