Я хочу отображать расписание рейсов на 3 дисплеях.Мы вносим изменения в расписание через документ Excel, и мой код отображает расписание, копируя изображение из Excel и вставляя его в работающую точку Power каждые x секунд.Однако я обеспокоен тем, что пользователи будут раздражены тем, что при запуске кода активируются 3 разных окна powerpoint, что прервет другую работу на компьютере.Сейчас я активирую окно и манипулирую слайдами.Это способ CopyPicture из Excel и вставка его в слайд уже работающей 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