Question

我正在尝试运行以下代码，当我到达ActivePresentation.Save时，我收到以下错误

错误 - 运行时错误'429'：ActiveX组件无法创建对象。

我已经搜索了这个问题并且似乎无法找到明确的答案，一些线程表明它可能是一个引用问题但是我已经更新了我的引用并且问题仍然存在。

Public Sub SaveNewVersion_PowerPoint()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault

Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
Dim TestStr As String
Dim myFileName As String


TestStr = ""
Saved = False
x = 2

'Version Indicator (change to liking)
  VersionExt = "_v"

'Pull info about file
  On Error GoTo NotSavedYet
    myPath = "C:\Users\Person\Desktop\Test\Weekly Pack Update.pptx"
    myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
    FolderPath = Left(myPath, InStrRev(myPath, "\"))
    SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
  On Error GoTo 0

'Determine if file has ever been saved
  If FolderPath = "" Then
    MsgBox "This file has not been initially saved. " & _
    "Cannot save a new version!", vbCritical, "Not Saved To Computer"
    Exit Sub
  End If

'Determine Base File Name
  If InStr(1, myFileName, VersionExt) > 1 Then
    myArray = Split(myFileName, VersionExt)
    SaveName = myArray(0)
  Else
    SaveName = myFileName
  End If

'Test to see if file name already exists
  If FileExist(FolderPath & SaveName & SaveExt) = False Then
    ActivePresentation.SaveAs FolderPath & SaveName & SaveExt 'Errors Here
    Exit Sub
  End If

'Need a new version made
  Do While Saved = False
    If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
      ActivePresentation.SaveAs FolderPath & SaveName & VersionExt & x & SaveExt 'Error Here
      Saved = True
    Else
      x = x + 1
    End If
  Loop

'New version saved
  MsgBox "New file version saved (version " & x & ")"

Exit Sub

'Error Handler
NotSavedYet:
  MsgBox "This file has not been initially saved. " & _
    "Cannot save a new version!", vbCritical, "Not Saved To Computer"

End Sub

Answer 1

我不能理解这是如何修复它但我宣布

Dim ppApp   As PowerPoint.Application
Dim ppPres  As PowerPoint.Presentation

然后加入

Set ppApp = New PowerPoint.Application
i = 1

ppApp.Presentations.Open Filename:=myPath
Set ppPres = ppApp.Presentations.Item(i)

最后改变

Activepresentation.saveAs

到

ppPres.SaveAs

它有效完整代码如下：

Public Sub SaveNewVersion_PowerPoint()
'PURPOSE: Save file, if already exists add a new version indicator to filename
'SOURCE: www.TheSpreadsheetGuru.com/The-Code-Vault

Dim FolderPath As String
Dim myPath As String
Dim SaveName As String
Dim SaveExt As String
Dim VersionExt As String
Dim Saved As Boolean
Dim x As Long
Dim TestStr As String
Dim myFileName As String


TestStr = ""
Saved = False
x = 2

'Version Indicator (change to liking)
  VersionExt = "_v"

'Pull info about file
  On Error GoTo NotSavedYet
    myPath = "C:\Users\Person\Desktop\Test\Weekly Pack Update.pptx"
    myFileName = Mid(myPath, InStrRev(myPath, "\") + 1, InStrRev(myPath, ".") - InStrRev(myPath, "\") - 1)
    FolderPath = Left(myPath, InStrRev(myPath, "\"))
    SaveExt = "." & Right(myPath, Len(myPath) - InStrRev(myPath, "."))
  On Error GoTo 0

'Determine if file has ever been saved
  If FolderPath = "" Then
    MsgBox "This file has not been initially saved. " & _
    "Cannot save a new version!", vbCritical, "Not Saved To Computer"
    Exit Sub
  End If

'Determine Base File Name
  If InStr(1, myFileName, VersionExt) > 1 Then
    myArray = Split(myFileName, VersionExt)
    SaveName = myArray(0)
  Else
    SaveName = myFileName
  End If

'Test to see if file name already exists
  If FileExist(FolderPath & SaveName & SaveExt) = False Then
    ActivePresentation.SaveAs FolderPath & SaveName & SaveExt 'Errors Here
    Exit Sub
  End If

'Need a new version made
  Do While Saved = False
    If FileExist(FolderPath & SaveName & VersionExt & x & SaveExt) = False Then
      ActivePresentation.SaveAs FolderPath & SaveName & VersionExt & x & SaveExt 'Error Here
      Saved = True
    Else
      x = x + 1
    End If
  Loop

'New version saved
  MsgBox "New file version saved (version " & x & ")"

Exit Sub

'Error Handler
NotSavedYet:
  MsgBox "This file has not been initially saved. " & _
    "Cannot save a new version!", vbCritical, "Not Saved To Computer"

End Sub

VBA Activepresentation.Saveas错误 - 429 ActiveX

1 个答案: