Превращение документа Word в PowerPoint. Копирование и вставка макросов VBA не работают - PullRequest
Новая
       105

Превращение документа Word в PowerPoint. Копирование и вставка макросов VBA не работают

0 голосов
/ 06 августа 2020

Я пытаюсь превратить документ Microsoft Word в презентацию PowerPoint. Я попытался вставить изображение, чтобы сохранить тот же формат, что и документ Word, используя приведенную ниже ссылку в качестве справки, поскольку вставка обычно вызывала серьезные проблемы с форматированием изображений и текста, разбросанных по всему слайду. Однако при вставке с использованием mySlide.CommandBars.ExecuteMso "PasteAsPicture" он иногда пропускает изображения и текст или копирует и вставляет его дважды, а при вставке таблиц форматирование полностью отключается. Я пытался замедлить приклеивание, но это тоже не помогло. Есть ли у сообщества идеи?

Как скопировать / вставить текстовое поле из MS Word в слайд Powerpoint? 

Sub WordToPowerPoint()

Dim rgePages As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

  On Error Resume Next

For Each oCC In ActiveDocument.ContentControls
        If oCC.Title = "FilePath12" Then
            fPath = oCC.Range.Text
        End If
        Next oCC

    Set pptApp = CreateObject("PowerPoint.Application")
      Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
    
      err.Clear

      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")

      If err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0

  Set myPresentation = PowerPointApp.presentations.Add
  
a = ActiveDocument.BuiltInDocumentProperties("Number of Pages")
For x = 1 To a

Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=x
Set rgePages = Selection.Range

rgePages.End = Selection.Bookmarks("\Page").Range.End
rgePages.Select

On Error Resume Next

    Selection.Copy
    Selection.CopyFormat
  
  Application.ScreenUpdating = False

 Set mySlide = myPresentation.Slides.Add(x, 12)

  Set mySlide = myPresentation.Slides(x)
  mySlide.Select

mySlide.ApplyTheme fPath
  pptApp.CommandBars.ExecuteMso "PasteAsPicture"
  
  Dim time1, time2

time1 = Now
time2 = Now + TimeValue("0:00:01")
    Do Until time1 >= time2
        DoEvents
        time1 = Now()
    Loop

Next x

End Sub
...