Question

我想在3个显示器上显示航班时刻表。我们通过excel文档对日程表进行更新，我的代码通过从excel复制图片并将其每隔x秒粘贴到运行的Powerpoint中来显示日程表。但是我担心用户会因为代码运行而激活3个不同的Powerpoint窗口而感到烦恼，这会中断计算机上的其他工作。就目前而言，我正在激活窗口并操纵幻灯片。他们有没有办法从Excel复制CopyPicture并将其粘贴到背景中已经运行的PowerPoint幻灯片中，而不激活窗口并分散用户注意力？

请不要判断我的代码效率低下...我正在通过google学习，并且大约10年没有代码。我还要粘贴幻灯片2，以便可以在将形状放到幻灯片1（显示器上的东西）之前放好形状，这样每次运行代码时都不会出现屏幕移位。

这是我的代码：

'Set the source workbook
Set wkbSource = ThisWorkbook

'Set the named range
Set rSource = ThisWorkbook.ActiveSheet.Range("B2:N70")
Set rSource2 = ThisWorkbook.ActiveSheet.Range("Q2:AC70")
Set rSource3 = ThisWorkbook.ActiveSheet.Range("AF2:AT70")


        '''''''''DISPLAY 1''''''''

'Get the existing instance of PowerPoint
Set oPPT = GetObject(, "PowerPoint.Application")

'Set the presentation
Set oPres = oPPT.Presentations("Display1.pptx")

'Clear contents of slide 2
    On Error Resume Next
    'Is the PowerPoint open?
    Set objApp = CreateObject("PowerPoint.Application")
    On Error GoTo 0

    If objApp Is Nothing Then Exit Sub

    If objApp.ActivePresentation Is Nothing Then Exit Sub

        Set objSlide = objApp.ActivePresentation.Slides(2)
            For Each ObjShp In objSlide.Shapes
                Select Case ObjShp.Type
                    Case msoPicture, msoTable, msoChart
                        ObjShp.Delete
                End Select
            Next

'Define Slide 2
Set oSlide2 = oPres.Slides(2)

'Copy the range as a picture
rSource.CopyPicture xlScreen, xlPicture

'Make the presentation the active presentation
oPres.Windows(1).Activate

'Paste picture in the newly added slide
Set oShape2 = oSlide2.Shapes.Paste(1)

'Go to the newly added slide
oPPT.ActiveWindow.View.GotoSlide oPres.Slides.Count

'Resize if Width is larger than slide
    NewWidth = oPres.PageSetup.SlideWidth
    If oShape2.Width > NewWidth Then
        oShape2.LockAspectRatio = msoTrue
        oShape2.Width = NewWidth - 50
    End If

'Resize if Height is larger than slide
  NewHeight = oPres.PageSetup.SlideHeight

    If oShape2.Height > NewHeight Then
        oShape2.LockAspectRatio = msoTrue
        oShape2.Height = NewHeight - 50
    End If

'Center the picture horizontally and vertically

With oPres.PageSetup
    oShape2.Left = (.SlideWidth / 2) - (oShape2.Width / 2)
    oShape2.Top = (.SlideHeight / 2) - (oShape2.Height / 2)
End With

With oPres

    .Slides(2).Shapes.Range(1).copy

    'Clear contents of slides
    On Error Resume Next
    'Is the PowerPoint open?
    Set objApp = CreateObject("PowerPoint.Application")
    On Error GoTo 0

    If objApp Is Nothing Then Exit Sub

    If objApp.ActivePresentation Is Nothing Then Exit Sub

        Set objSlide = objApp.ActivePresentation.Slides(1)
            For Each ObjShp In objSlide.Shapes
                Select Case ObjShp.Type
                    Case msoPicture, msoTable, msoChart
                        ObjShp.Delete
                End Select
            Next


    .Slides(1).Shapes.Paste
    .Slides(1).Select

End With

此操作将继续更新另外2个PowerPoint演示文稿。感谢您的任何事先帮助！

JR

如何在不激活Powerpoint窗口的情况下从Excel更新Powerpoint幻灯片

0 个答案: