使用 VBA 从 Excel 2010 中查找和替换 Powerpoint 2010 中的文本

Find and replace text in Powerpoint 2010 from Excel 2010 with VBA

提问by user1284325

I successfully used this code within a powerpoint odule, but when I move it inside my excel module it gives me several problems. I embedded the Powerpoint application on sheet 1 of Excel. The goal is to generate the powerpoint from excel and replace the company name whenever it appears on a powerpoint slide with the new company name from an excel range. I get error 429 ActiveX component cant create object at "For Each osld In ActivePresentation.Slides. Is my Powerpoint presentation not active? Any help would be appreciated. Using excel/Powerpoint 2010.

我成功地在 powerpoint odule 中使用了这段代码，但是当我将它移到我的 excel 模块中时，它给了我几个问题。我在 Excel 的工作表 1 上嵌入了 Powerpoint 应用程序。目标是从 excel 生成 powerpoint，并在 PowerPoint 幻灯片上出现时将公司名称替换​​为 excel 范围内的新公司名称。我收到错误 429 ActiveX 组件无法在“为 ActivePresentation.Slides 中的每个 osld 创建对象。我的 Powerpoint 演示文稿未处于活动状态吗？任何帮助将不胜感激。使用 excel/Powerpoint 2010。

Sub changeme(sFindMe As String, sSwapme As String) 
Dim osld As Slide 
Dim oshp As Shape 
Dim otemp As TextRange 
Dim otext As TextRange 
Dim Inewstart As Integer 



For Each osld In ActivePresentation.Slides 
For Each oshp In osld.Shapes 
    If oshp.HasTextFrame Then 
        If oshp.TextFrame.HasText Then 

            Set otext = oshp.TextFrame.TextRange 
            Set otemp = otext.Replace(sFindMe, sSwapme, , msoFalse, msoFalse) 
            Do While Not otemp Is Nothing 
                Inewstart = otemp.Start + otemp.Length 
                Set otemp = otext.Replace(sFindMe, sSwapme, Inewstart, msoFalse, msoFalse) 
            Loop 

        End If 
    End If 

Next oshp 
Next osld 
End Sub 
 '-------------------------------------------------------------------------
Sub swap() 
Dim sFindMe As String 
Dim sSwapme As String 
Dim ppApp As PowerPoint.Application 
Dim ppPreso As PowerPoint.Presentation 

 'Start Powerpoint

 'Look for existing instance
On Error Resume Next 
Set ppApp = GetObject(, "PowerPoint.Application") 
On Error Goto 0 

 'Create new instance if no instance exists
Set ppApp = CreateObject("Powerpoint.Application") 



 'Open Template in word
With Sheets("Sheet1").Shapes("Object 1").OLEFormat.Verb(Verb:=xlVerbOpen) 
End With 
 'Make it visible
ppApp.Visible = True 



sFindMe = "Name To Find" 
 'change this to suit
sSwapme = "New Name" 
Call changeme(sFindMe, sSwapme) 
 'sFindMe = "<find2>"
 'sSwapme = ActivePresentation.Slides(1).Shapes(2).TextFrame.TextRange
 'Call changeme(sFindMe, sSwapme)
End Sub 

回答by Siddharth Rout

ActivePresentationis a Powerpoint Object. It doesn't mean anything to Excel. When you open a presentation you have to set a connection to it for Excel to relate with it. I would suggest using the below code. Also I have used Late Binding so you don't need to add any reference to MS Powerpoint from Excel.

ActivePresentation是一个 Powerpoint 对象。这对 Excel 没有任何意义。当您打开演示文稿时，您必须设置到它的连接，以便 Excel 与之关联。我建议使用下面的代码。此外，我使用了后期绑定，因此您无需从 Excel 添加对 MS Powerpoint 的任何引用。

LOGIC:

逻辑：

• Save the embedded PPT to a temp folder
• Open the file in Excel and then make the changes

• 将嵌入的 PPT 保存到临时文件夹
• 在 Excel 中打开文件，然后进行更改

TRIED AND TESTED

久经考验

Private Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long

Dim ppApp As Object, ppPreso As Object, ppPresTemp As Object

Sub swap()
    Dim sFindMe As String, sSwapme As String, FlName As String
    Dim objOLE As OLEObject
    Dim sh As Shape

    '~~> Decide on a temporary file name which will be saved in the
    '~~> users temporary folder. You might want to change the extention 
    '~~> from pptx to ppt if you are using earlier versions of MS Office
    FlName = GetTempDirectory & "\Temp.pptx"

    Set sh = Sheets("Sheet1").Shapes("Object 1")

    sh.OLEFormat.Activate

    Set objOLE = sh.OLEFormat.Object

    Set ppPresTemp = objOLE.Object

    '~~> Save the file to the relevant temp folder
    ppPresTemp.SaveAs Filename:=FlName

    '~~> Close the temp presentation that opened
    ppPresTemp.Close

    '~~> Establish an Powerpoint application object
    On Error Resume Next
    Set ppApp = GetObject(, "PowerPoint.Application")

    If Err.Number <> 0 Then
        Set ppApp = CreateObject("PowerPoint.Application")
    End If
    Err.Clear
    On Error GoTo 0

    ppApp.Visible = True

    Set ppPreso = ppApp.Presentations.Open(Filename:=FlName)

    sFindMe = "Name To Find"
    sSwapme = "New Name"

    changeme sFindMe, sSwapme


    '~~> In the end Clean Up (Delete the temp file saved in the temp directory)
    'Kill FlName
End Sub

Sub changeme(sFindMe As String, sSwapme As String)
    Dim osld As Object, oshp As Object
    Dim otemp As TextRange, otext As TextRange
    Dim Inewstart As Integer

    For Each osld In ppPreso.Slides
        For Each oshp In osld.Shapes
            If oshp.HasTextFrame Then
                If oshp.TextFrame.HasText Then
                    Set otext = oshp.TextFrame.TextRange

                    Set otemp = otext.Replace(sFindMe, sSwapme, , _
                    msoFalse, msoFalse)

                    Do While Not otemp Is Nothing
                        Inewstart = otemp.Start + otemp.Length
                        Set otemp = otext.Replace(sFindMe, sSwapme, _
                        Inewstart, msoFalse, msoFalse)
                    Loop
                End If
            End If
        Next oshp
    Next osld
End Sub

'~~> Function to get the user's temp directory
Function GetTempDirectory() As String
   Dim buffer As String
   Dim bufferLen As Long
   buffer = Space$(256)
   bufferLen = GetTempPath(Len(buffer), buffer)
   If bufferLen > 0 And bufferLen < 256 Then
      buffer = Left$(buffer, bufferLen)
   End If
   If InStr(buffer, Chr$(0)) <> 0 Then
      GetTempDirectory = Left$(buffer, InStr(buffer, Chr$(0)) - 1)
   Else
      GetTempDirectory = buffer
   End If
End Function

Hope this helps :)

希望这可以帮助 ：）

Sid

锡德