在Excel 2010中使用VBA查找和替换Powerpoint 2010中的文本 [英] Find and replace text in Powerpoint 2010 from Excel 2010 with VBA
问题描述
我在一个powerpoint odule中成功地使用了这个代码,但是当我将其移动到我的excel模块中时,它给了我几个问题。我在Excel的表格1中嵌入了Powerpoint应用程序。目标是从excel生成powerpoint,并在公司名称从excel范围新出现在powerpoint幻灯片上时更换公司名称。
我得到错误429 ActiveX组件不能创建对象在For Each osld In ActivePresentation.Slides。我的Powerpoint演示文稿是否活动?任何帮助将不胜感激使用excel / Powerpoint 2010。
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.
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
推荐答案
ActivePresentation
是一个Powerpoint对象。 Excel并不意味着什么。当您打开演示文稿时,您必须设置一个与Excel相关联的连接。我建议使用下面的代码。另外我使用了Late Binding,所以你不需要从Excel中添加任何对MS Powerpoint的引用。
ActivePresentation
is 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.
LOGIC :
- 将嵌入式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
希望这有帮助:)
Sid
这篇关于在Excel 2010中使用VBA查找和替换Powerpoint 2010中的文本的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!