gpt4 book ai didi

excel - 使用 VBA 在 Excel 2010 中查找和替换 Powerpoint 2010 中的文本

转载 作者:行者123 更新时间:2023-12-02 11:26:58 24 4
gpt4 key购买 nike

我在一个 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

最佳答案

ActivePresentation是一个PowerPoint对象。这对 Excel 没有任何意义。当您打开演示文稿时,您必须设置与它的连接,以便 Excel 与之关联。我建议使用下面的代码。此外,我使用了后期绑定(bind),因此您无需从 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

    希望这可以帮助 :)

    席德

    关于excel - 使用 VBA 在 Excel 2010 中查找和替换 Powerpoint 2010 中的文本,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/9811723/

    24 4 0
    Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
    广告合作:1813099741@qq.com 6ren.com