ActivePresentation
是一个Powerpoint对象。这对 Excel 来说没有任何意义。当您打开演示文稿时,您必须设置与它的连接,以便 Excel 与其关联。我建议使用下面的代码。此外,我还使用了“后期绑定”,因此您无需从 Excel 添加对 MS Powerpoint 的任何引用。
LOGIC:
- 将嵌入的 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