使用 Model3D 的 VBA Powerpoint：如何刷新幻燈片

Question

我在 Windows 10 上使用最新版本的 Powerpoint。我正在嘗試使用以下代碼旋轉 3d 模型，但每次執行 IncrementRotationX 時都不會刷新屏幕3d 對象，以便它平滑地顯示屏幕上的旋轉？ 任何幫助，將不勝感激。

Sub Program()

  Set myDocument = ActivePresentation.Slides(8)

    Dim x As Integer
    Dim y As Integer
    Dim z As Integer

  'Save current position
    x = ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationX
    y = ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationY
    z = ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationZ

   MsgBox "RESET Position"

  For i = 1 To 45
  With myDocument
        .Shapes("3D Model 3").Model3D.IncrementRotationX (1)
        .Shapes("3D Model 3").Model3D.IncrementRotationY (1)
        .Shapes("3D Model 3").Model3D.IncrementRotationZ (1)
    End With
  Next i



   MsgBox "End of routine"

'reset position to starting point

   ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationX = x
   ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationY = y
   ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationZ = z



  End Sub

我希望我的對象在幻燈片中平滑旋轉，但事實並非如此。 它只是搖晃到最后一個位置； 它不會更新和刷新以顯示它在我“IncrementRotationX(1)”時旋轉

Answer 1

為了平滑旋轉或動畫，需要在循環之間等待一段時間。 一種可能的方法是等待 1 秒。 （等待少於 1 秒，請參閱此處的解決方案 - 如何在 excel vba 中提供少於 1 秒的時間延遲？ ）

因此，在循環中寫入Wait1Second ：

  For i = 1 To 45
  With myDocument
        .Shapes("3D Model 3").Model3D.IncrementRotationX (1)
        .Shapes("3D Model 3").Model3D.IncrementRotationY (1)
        .Shapes("3D Model 3").Model3D.IncrementRotationZ (1)
  End With
  WaitASecond
  Next i

這是子Wait1Second() ：

Sub Wait1Second()
    Application.Wait (Now + #12:00:01 AM#)
End Sub

這是 Excel 中的演示：

演示代碼：

Option Explicit

Sub TestMe()

    Dim cnt As Long
    For cnt = 1 To 3
        Wait1Second
        WriteCircle 15, 1, 1
        Wait1Second
        WriteCircle 15, 1, 2
        Wait1Second
        WriteCircle 15, 2, 1
        Wait1Second
        WriteCircle 15, 2, 2
    Next cnt

End Sub

Sub WriteCircle(sizeX As Long, stepX As Long, stepY As Long)

    Dim sizeY As Long: sizeY = sizeX
    Dim y&, x&, r&, g&, b&
    Dim myCell As Range
    Worksheets(1).Cells.Clear

    For x = 1 To sizeX Step stepX
        For y = 1 To sizeY Step stepY
            With Worksheets(1)
                Set myCell = .Cells(x, y)

                If r >= 255 Then
                    If g >= 255 Then
                        b = b + 2
                    Else
                        g = g + 2
                    End If
                Else
                    r = r + 2
                End If
                myCell.Interior.Color = RGB(r, g, b)
            End With
        Next
    Next

End Sub