使用VBA在Excel 2010中查找並替換Powerpoint 2010中的文本

Question

我成功地在PowerPoint模塊中使用了該代碼，但是當我將其移動到我的Excel模塊中時，它給了我幾個問題。我將PowerPoint應用程序嵌入到Excel表格1中。我們的目標是從excel中生成powerpoint，並且在出現在powerpoint幻燈片上時用公司名稱出現在excel範圍內的公司名稱替換​​公司名稱。 我得到錯誤429 ActiveX組件不能在創建對象「對於每個osld在ActivePresentation.Slides。是我的簡報不積極？任何幫助，將不勝感激。使用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 

Answer 1

ActivePresentation是一個PowerPoint對象，它對Excel沒有任何意義，當你打開一個演示文稿時，你必須爲它設置一個連接來與Excel進行關聯，我會建議使用下面的代碼，並且我使用了Late Binding，所以你不需要需要在Excel中添加對MS Powerpoint的任何參考。

邏輯：

• 保存嵌入式PPT到一個臨時文件夾
• 在Excel中打開該文件，然後進行更改

久經考驗

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 

希望這有助於:)

Sid