Question

我正在Windows 10上使用最新版本的Powerpoint。我正在尝试使用下面的代码旋转3D模型，但是每次执行IncrementRotationX时它都不会刷新屏幕是否有一个特殊的函数调用来获取powerpoint来刷新/重绘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

我期望我的对象在PowerPoint幻灯片中平稳旋转，但不会旋转。它只是摇晃到最后一个位置。它没有更新和刷新以显示它随着我的“ IncrementRotationX（1）”旋转

Answer 1

为平滑旋转或动画，需要在循环之间等待一段时间。一种可能的方法是等待1秒钟。（要等待不到1秒，请在此处查看解决方案-How to give a time delay of less than one second in excel vba?）

因此，在循环中写入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

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

1 个答案: