一个来自微软的插件：3D旋转

朋友们是否发现了：在给形状添加3D效果之后，如果你要旋转图形，它只能围绕Z轴旋转，要围绕X、Y轴旋转十分不方便，为此，
微软专家John H和 Reiher Jr写了一个PPT插件，允许你围绕X、Y、Z轴的任何一轴自由旋转。
这是一个免费插件，没有实现“动画旋转”功能，不知道其他人是否有完整功能的版本。有的话拿出来分享一下。

 

把插件的代码也一并公布了吧：
这是窗体代码：
' Rotate Me PPTVB project
' By John H. Reiher Jr.
' Define default axis variables, to store initial X,Y positions
' of the object being rotated.
Dim defX As Integer
Dim defY As Integer
Dim defZ As Integer
Dim objName As String
' Define variables used for rotation
Dim newX As Integer
Dim newY As Integer
Dim newZ As Integer
' Define variables used in error checking
Dim lastX As Integer
Dim lastY As Integer
Dim lastZ As Integer

Private Sub Cancelbut_Click()
' Reset object back to original X-Y-Z coords'
' unload VBapp.
    ActiveWindow.Selection.ShapeRange.ThreeD.RotationX = defX
    ActiveWindow.Selection.ShapeRange.ThreeD.RotationY = defY
    ActiveWindow.Selection.ShapeRange.Rotation = defZ
    Unload Me
End Sub
Private Sub cmdReset_Click()
' Reset object back to original X-Y-Z coords'
' Set axis text boxes to original values.
    If chkFancy.Value = True Then
        newX = Xaxis.Value
        newY = Yaxis.Value
        newZ = Zaxis.Value
        FancyRot defX, defY, defZ
    Else
        ActiveWindow.Selection.ShapeRange.ThreeD.RotationX = defX
        ActiveWindow.Selection.ShapeRange.ThreeD.RotationY = defY
        ActiveWindow.Selection.ShapeRange.Rotation = defZ
    End If
    cmdReset.Enabled = False
    Xaxis.Value = defX
    Yaxis.Value = defY
    Zaxis.Value = defZ
End Sub
Private Sub OKbut_Click()
' run RotMe subroutine, unload program.
    RotMe
    Unload Me
End Sub
Private Sub preview_Click()
' Run RotMe so user can see if rotation is acceptable.
    RotMe
    cmdReset.Enabled = True
End Sub
Private Sub SpinButton1_SpinDown()
' nudge down Y axis value. Check for bounds.
    Yaxis.Value = Yaxis.Value - SpinButton1.SmallChange
    If Yaxis.Value < -90 Then
        Yaxis.Value = -90
    End If
End Sub
Private Sub SpinButton1_SpinUp()
' nudge up Y axis value. Check for bounds.
    Yaxis.Value = Yaxis.Value + SpinButton1.SmallChange
    If Yaxis.Value > 90 Then
        Yaxis.Value = 90
    End If
End Sub
Private Sub SpinButton2_SpinDown()
' nudge down X axis value. Check for bounds.
    Xaxis.Value = Xaxis.Value - SpinButton2.SmallChange
    If Xaxis.Value < -90 Then
        Xaxis.Value = -90
    End If
End Sub
Private Sub SpinButton2_SpinUp()
' nudge up X axis value. Check for bounds.
    Xaxis.Value = Xaxis.Value + SpinButton2.SmallChange
    If Xaxis.Value > 90 Then
        Xaxis.Value = 90
    End If
End Sub
Private Sub SpinButton3_SpinDown()
' nudge down Z axis value. Check for bounds.
    Zaxis.Value = Zaxis.Value - SpinButton3.SmallChange
End Sub
Private Sub SpinButton3_SpinUp()
' nudge up Z axis value. Check for bounds.
    Zaxis.Value = Zaxis.Value + SpinButton3.SmallChange
End Sub
Private Sub UserForm_Activate()
' grab X, Y, Z axis coords for object
' set text boxes to same numbers
' set reserved variables.
    defX = ActiveWindow.Selection.ShapeRange.ThreeD.RotationX
    defY = ActiveWindow.Selection.ShapeRange.ThreeD.RotationY
    If ActiveWindow.Selection.ShapeRange.Rotation > 180 Then
        defZ = ActiveWindow.Selection.ShapeRange.Rotation - 360
    Else
        defZ = ActiveWindow.Selection.ShapeRange.Rotation
    End If
    Xaxis.Value = defX
    Yaxis.Value = defY
    Zaxis.Value = defZ
    lastX = defX
    lastY = defY
    lastZ = defZ
    objName = ActiveWindow.Selection.ShapeRange.Name
    cmdReset.Enabled = False
End Sub
Function RotMe()
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim i As Integer
Dim k As Integer
    ' Is it Blank?
    ' yes, set to zero
    ' else set to axis value.
    On Error Resume Next
    Err.Clear
   
    If Xaxis.Value = "" Then
        x = 0
        Xaxis.Value = x
    Else
        x = Xaxis.Value
    End If
   
    If Yaxis.Value = "" Then
        y = 0
        Yaxis.Value = y
    Else
        y = Yaxis.Value
    End If
   
    If Zaxis.Value = "" Then
        z = 0
        Zaxis.Value = z
    Else
        z = Zaxis.Value
    End If
   
    If Err.Number <> 0 Then
        MsgBox "Please enter a value between -90 and +90"
        Xaxis.Value = lastX
        Yaxis.Value = lastY
        Zaxis.Value = lastZ
    Else
   
    ' Is it bigger than 90?
    ' yes, then set it to 90
    ' no is it less than -90
    ' yes then set it to -90
    If Xaxis.Value > 90 Then
        x = 90
        Xaxis.Value = x
    Else
        If Xaxis.Value < -90 Then
            x = -90
            Xaxis.Value = x
        End If
    End If
   
    If Yaxis.Value > 90 Then
        y = 90
        Yaxis.Value = y
    Else
        If Yaxis.Value < -90 Then
            y = -90
            Yaxis.Value = y
        End If
    End If
   
    If Zaxis.Value > 360 Then
        z = Zaxis.Value - 360
        Zaxis.Value = z
    Else
        If Zaxis.Value < -360 Then
             z = Zaxis.Value + 360
            Zaxis.Value = z
        End If
    End If
   
    ' set axis to new location.
    If chkFancy.Value = True Then
        newX = ActiveWindow.Selection.ShapeRange.ThreeD.RotationX
        newY = ActiveWindow.Selection.ShapeRange.ThreeD.RotationY
        If ActiveWindow.Selection.ShapeRange.Rotation = lastZ Then
            newZ = ActiveWindow.Selection.ShapeRange.Rotation
        Else
            newZ = lastZ
        End If
        FancyRot x, y, z
    Else
        ActiveWindow.Selection.ShapeRange.ThreeD.RotationY = y
        ActiveWindow.Selection.ShapeRange.ThreeD.RotationX = x
        ActiveWindow.Selection.ShapeRange.Rotation = z
    End If
    lastX = x
    lastY = y
    lastZ = z
    End If
End Function
Function FancyRot(x As Integer, y As Integer, z As Integer)
Dim Ix As Integer
Dim Iy As Integer
Dim Iz As Integer
Dim Kx As Integer
Dim Ky As Integer
Dim Kz As Integer
    If newX >= x Then
        Kx = -1
    Else
        Kx = 1
    End If
    If newY >= y Then
        Ky = -1
    Else
        Ky = 1
    End If
    If newZ >= z Then
        Kz = -1
    Else
        Kz = 1
    End If
   
    For Iy = newY To y Step Ky
    ActiveWindow.Selection.SlideRange.Shapes(objName).Select
    ActiveWindow.Selection.ShapeRange.ThreeD.RotationY = Iy
    ActiveWindow.Selection.Unselect
    Next Iy
    For Ix = newX To x Step Kx
    ActiveWindow.Selection.SlideRange.Shapes(objName).Select
    ActiveWindow.Selection.ShapeRange.ThreeD.RotationX = Ix
    ActiveWindow.Selection.Unselect
    Next Ix
   
    For Iz = newZ To z Step Kz
    ActiveWindow.Selection.SlideRange.Shapes(objName).Select
    ActiveWindow.Selection.ShapeRange.Rotation = Iz
    ActiveWindow.Selection.Unselect
    Next Iz
   
    ActiveWindow.Selection.SlideRange.Shapes(objName).Select
   
End Function

[ 本帖最后由 无极 于 2008-5-29 09:58 编辑 ]