[英]Excel VBA to PPT not working in office 365 64 bit
我在 excel 的所有版本上都使用了以下代碼 - 基本上我創建了一個具有 ppt 外觀的 excel 工作表並將工作表范圍導出到 PPT。
Excel VBA 導出到 PPT 在 Office 365 32 位之前的所有版本中都可以正常工作
嘗試了以下檢查參考 - 使用 14,15,16 object 庫 - 工作正常..
不適用於 64 位 - Excel 365 給出錯誤 - “找不到 PowerPoint”
Sub ExcelRangeToPPT_new_now()
'prepareppt
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.IgnoreRemoteRequests = True
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
'Sheets("S19").Select
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("A1:q36")
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
Sheets("template").Select
Set rng = ThisWorkbook.ActiveSheet.Range("A1:q36")
instfile = "Noattach"
If ActFileName = False Then
'PowerPointApp.Activate
'PowerPointApp.Presentations.Add
'Set PP_File = PowerPointApp.ActivePresentation
Else
PowerPointApp.Activate
Set myPresentation = PowerPointApp.Presentations.Open(ActFileName)
End If
Set myPresentation = PowerPointApp.Presentations.Add
Set PP_File = PowerPointApp.ActivePresentation
adddd:
DoEvents
Set rng = ThisWorkbook.ActiveSheet.Range("A1:q36")
PowerPointApp.Visible = True
'Create a New Presentation
rrr:
err.Clear
Set mySlide = PP_File.Slides.Add(1, 12) '11 = ppLayoutTitleOnly
PP_File.Slides (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
With PP_File.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideWidth = 720
.SlideHeight = 528
.FirstSlideNumber = 1
.SlideOrientation = msoOrientationHorizontal
.NotesOrientation = msoOrientationVertical
End With
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 0
myShape.Top = 0
myShape.LockAspectRatio = msoFalse
myShape.HEIGHT = 528
myShape.WIDTH = 718
If instfile <> "Noattach" Then
Dim objPPTShape As Object
Set objPPTShape = PP_File.Slides(1).Shapes.AddOLEObject(Left:=100, Top:=100, WIDTH:=700, HEIGHT:=300, _
filename:=instfile, DisplayAsIcon:=True) 'OR Use , Filename:="E:\Documents and Settings\User\My Documents\abc.xlsm" instead of ClassName but not both
With objPPTShape
.Left = 475
.Top = 350
End With
Set objPPTShape = Nothing
End If
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
PowerPointApp.PageSetup.SlideOrientation = msoOrientationHorizontal
sht = sht - 1
If sht = 1 Then Sheets("template").Select: GoTo ttre
instfile = "Noattach"
If sht = 2 Then Sheets("S2").Select: GoTo adddd
ttre:
Sheets("main").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.IgnoreRemoteRequests = False
MsgBox "PPT Created Sucessfully.. Kindly review it before saving it.. "
Exit Sub
err:
Debug.Print "Error No.: " & err.Number & vbNewLine & vbNewLine & "Description: " & err.Description, vbCritical, "Error"
If err.Number = -2147467259 Then
MsgBox "Error Occured - Check if the Files to be embedded or the destination PPT is in the same folder as that of the Excel file..."
End If
If err.Number = 462 Then
Set PP_File = PowerPointApp.Presentations.Add
GoTo rrr
End If
If err.Number = 16 Then
MsgBox "Check if the Excel Files to be embedded is in the same folder.."
End
End If
End Sub
我對 Excel 和 On Error Resume Next 代碼有類似的問題。 盡管我很少使用它(我更喜歡體驗所有錯誤並適當地處理它們),但它在某些有限的情況下可能很有用。 我找到了重新思考一些代碼的方法,例如,在你的例子中你展示了這個:
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
我將把這段代碼重新編碼如下:
bPPOpen = GetObject(class:="PowerPoint.Application")
If bPPOpen Then
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Else bPPOpen = False Then
Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
Endif
使用此技術,您無需嘗試設置 object,除非您知道它可用。 此外,由於您沒有使用引發的錯誤,因此您不必處理一些錯誤“清理”。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.