controls.frm

arcEngine开发globe动画控件

        cycles = frmGlbCntrl.TxtFrequency.Text
        iteration = CInt(frmGlbCntrl.txtDuration.Text)
        cycles = CInt(frmGlbCntrl.TxtFrequency.Text)
        'playanimation via iteration...
        PlayAnimationFast cycles, iteration
    End If
    

  Exit Sub
ErrorHandler:
  HandleError True, "CmdPlay_Click " & c_sModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 4
End Sub

Private Sub PlayAnimation(duration As Double, numCycles As Integer)
  On Error GoTo ErrorHandler


  Dim IpViewers3D As esri3DAnalyst.IViewers3D
  Dim startTime As Single
  Dim elapsedTime As Single
  Dim i As Integer
  Dim j As Integer
  Dim pglobe As esriglobecore.IGlobe
  Dim pTracks As esri3DAnalyst.IAnimationTracks
  Set pglobe = frmGlbCntrl.GlobeControl.Globe
  Set pTracks = pglobe
  Set IpViewers3D = pglobe.GlobeDisplay
  numCycles = CInt(numCycles)
  
  'exit if document doesnt contain animation..
  If pTracks.TrackCount = 0 Then
        Dim sError As String
        sError = m_sAnimFilePath
        If sError = "" Then
            sError = "To get a Sample animation file, DeveloperKit Samples need to be installed!"
            MsgBox "The current document doesnt contain animation file." _
            & vbCrLf & sError
        Else
            MsgBox "The current document doesnt contain animation file." _
            & vbCrLf & "Load " & m_sAnimFilePath & "\AnimationSample.aga for sample."
        End If
    Exit Sub
  End If
  For i = 1 To numCycles Step 1
    startTime = Timer
    j = 0
    Do
      elapsedTime = Timer - startTime
      If (elapsedTime > duration) Then
        elapsedTime = duration
      End If
      pTracks.ApplyTracks Nothing, elapsedTime, duration
      IpViewers3D.RefreshViewers
            j = j + 1
    Loop While elapsedTime < duration
  Next i


  Exit Sub
ErrorHandler:
  HandleError False, "PlayAnimation " & c_sModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 4
End Sub

Private Sub PlayAnimationFast(Optional ByVal cycles As Integer, Optional ByVal iteration As Integer)
  On Error GoTo ErrorHandler

  Dim pglobe As esriglobecore.IGlobe
  Dim pglobedisp As esriglobecore.IGlobeDisplay
  Set pglobe = frmGlbCntrl.GlobeControl.Globe
  Set pglobedisp = pglobe.GlobeDisplay
  Dim pScene As esri3DAnalyst.Scene
  Set pScene = pglobedisp.Scene
  Dim pSceneTracks As esri3DAnalyst.IAnimationTracks
  Dim pTrackGlobe As esri3DAnalyst.IAnimationTrack
  Dim pTrackCamera As esri3DAnalyst.IAnimationTrack
  Dim pTrackLayer As esri3DAnalyst.IAnimationTrack
  Dim pTrack As esri3DAnalyst.IAnimationTrack
  Dim PTrackCamArray As esriSystem.IArray
  Dim PTrackGlbArray As esriSystem.IArray
  Dim PTrackLyrArray As esriSystem.IArray
  Dim pKFBkmark As esri3DAnalyst.IKeyframe
  Dim pKFGlbCam As esri3DAnalyst.IKeyframe
  Dim pkFGlbLayer As esri3DAnalyst.IKeyframe
  Dim pAnimType As esri3DAnalyst.IAnimationType
  Dim pAnimGlobeCam As esri3DAnalyst.IAnimationType
  Dim pAnimCam As esri3DAnalyst.IAnimationType
  Dim PAnimLayer As esri3DAnalyst.IAnimationType
  Set pSceneTracks = pScene
  Dim IntCount() As Integer
  Dim k, IntKeyFrameTot, i As Integer
  Dim ii As Integer
  Dim animCount As Integer
  Dim pCollection As Collection
  Dim stype As String
  Dim bfound As Boolean
  Set pCollection = New Collection
  Set PTrackCamArray = New esriSystem.Array
  Set PTrackGlbArray = New esriSystem.Array
  Set PTrackLyrArray = New esriSystem.Array
  
    If pSceneTracks.TrackCount = 0 Then
        Dim sError As String
        sError = m_sAnimFilePath
        If sError = "" Then
            sError = "To get a Sample animation file, DeveloperKit Samples need to be installed!"
            MsgBox "The current document doesnt contain animation file." _
            & vbCrLf & sError
        Else
            MsgBox "The current document doesnt contain animation file." _
            & vbCrLf & "Load " & m_sAnimFilePath & "\AnimationSample.aga for sample."
        End If
        
        Exit Sub
    End If
  'get Each track from the scene and store traks of the same kind in in an Array
    For i = 0 To pSceneTracks.TrackCount - 1
        Set pTrack = pSceneTracks.Tracks.Element(i)
        ReDim Preserve IntCount(i)
        k = i
        Set pAnimType = pTrack.AnimationType
        If pAnimType.clsid = "{7CCBA704-3933-4D7A-8E89-4DFEE88AA937}" Then 'GlobeLayer
             Set pTrackLayer = New AnimationTrack
             Set pTrackLayer = pTrack
             Set pTrackLayer.AnimationType = pAnimType
             Set pkFGlbLayer = New GlobeLayerKeyframe
             Set PAnimLayer = pAnimType
             IntCount(i) = pTrackLayer.KeyframeCount        'Store the keyframe count of each track in an array
             PTrackLyrArray.Add pTrackLayer
        ElseIf pAnimType.clsid = "{D4565495-E2F9-4D89-A8A7-D0B69FD7A424}" Then 'Globe Camera type
             Set pTrackGlobe = New AnimationTrack
             Set pTrackGlobe = pTrack
             Set pTrackGlobe.AnimationType = pAnimType
             Set pKFGlbCam = New GlobeCameraKeyframe
             Set pAnimGlobeCam = pAnimType
             IntCount(i) = pTrackGlobe.KeyframeCount          'Store the keyframe count of each track in an array
             PTrackGlbArray.Add pTrackGlobe
        Else
            MsgBox "Animation Type " & pAnimType.Name & " Not Supported. Check if the animation File is Valid!"
            Exit Sub
        End If
    Next
  
  
    Dim time As Double
    Dim IntLarger As Integer
    Dim IterStart As Integer

     IntLarger = Greatest(IntCount())
   
   If iteration = Empty Then iteration = IntLarger  ' if nothing gets passed by the argument it takes the max no of keyframes
    Dim j As Integer
    Dim intKfmCamCnt As Integer
    Dim intKfmCnt As Integer
    For i = 1 To cycles 'Total number of cycles
    For IterStart = 0 To iteration  ' no of iterations...
            For j = 0 To PTrackCamArray.count - 1
            Set pTrackCamera = PTrackCamArray.Element(j)
            If Not pTrackCamera Is Nothing Then
            If time >= pTrackCamera.BeginTime Then
               intKfmCamCnt = pTrackGlobe.KeyframeCount
                Set pKFBkmark = pTrackCamera.Keyframe(intKfmCamCnt - intKfmCamCnt)
                'reset object
                pAnimCam.ResetObject pScene, pKFBkmark
                ' interpolate by using track
                pTrackCamera.InterpolateObjectProperties pScene, time
                intKfmCamCnt = intKfmCamCnt - 1
            End If
            End If
            Next
            For k = 0 To PTrackGlbArray.count - 1
            Set pTrackGlobe = PTrackGlbArray.Element(k)
            If Not pTrackGlobe Is Nothing Then
                If time >= pTrackGlobe.BeginTime Then
                intKfmCnt = pTrackGlobe.KeyframeCount
                Set pKFGlbCam = pTrackGlobe.Keyframe(pTrackGlobe.KeyframeCount - intKfmCnt)
                'reset object
                pAnimGlobeCam.ResetObject pScene, pKFGlbCam
                ' interpolate by using track
                pTrackGlobe.InterpolateObjectProperties pScene, time
                intKfmCnt = intKfmCnt - 1
                End If
            End If
            Next
            
            Dim t As Integer
            Dim intKfmLyrCnt As Integer
            For t = 0 To PTrackLyrArray.count - 1
            Set pTrackLayer = PTrackLyrArray.Element(t)
            If Not pTrackLayer Is Nothing Then
            If time >= pTrackLayer.BeginTime Then
                intKfmLyrCnt = pTrackLayer.KeyframeCount
                Set pkFGlbLayer = pTrackLayer.Keyframe(pTrackLayer.KeyframeCount - intKfmLyrCnt)
                'interpolate by using track
                pTrackLayer.InterpolateObjectProperties pScene, time
                intKfmLyrCnt = intKfmLyrCnt - 1
            End If
            End If
            Next
        'reset interpolation Point
            time = IterStart / iteration
        'refresh the globeviewer(s)
            pglobedisp.RefreshViewers
    Next IterStart
    Next

  Exit Sub
ErrorHandler:
  HandleError False, "PlayAnimationFast " & c_sModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 4
   End Sub
Private Function Greatest(ByRef pArray() As Integer) As Integer
  On Error GoTo ErrorHandler

    ' Function to find the largest count of keyframes (in any one of the Animation tracks)

Dim intLength As Integer
intLength = UBound(pArray)
ReDim Preserve pArray(intLength)
Dim i As Integer
Dim IntMax As Integer
For i = 0 To intLength

        If IntMax = Empty Then
            IntMax = pArray(i)
        ElseIf pArray(i) > IntMax Then
            IntMax = pArray(i)
        End If
Next
 Greatest = IntMax


  Exit Function
ErrorHandler:
  HandleError False, "Greatest " & c_sModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 4
End Function

Private Sub OptDuration_Click()
  On Error GoTo ErrorHandler


frmGlbCntrl.txtDuration.Text = 10 'set default values
frmGlbCntrl.TxtFrequency = 2 'set Default values


  Exit Sub
ErrorHandler:
  HandleError True, "OptDuration_Click " & c_sModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 4
End Sub

Private Sub OptIteration_Click()
  On Error GoTo ErrorHandler


'Set Default cycle and iteration..
frmGlbCntrl.txtDuration.Text = 500
frmGlbCntrl.TxtFrequency = 2


  Exit Sub
ErrorHandler:
  HandleError True, "OptIteration_Click " & c_sModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 4
End Sub

Private Sub ToolbarControl_OnItemClick(ByVal index As Long)
  On Error GoTo ErrorHandler
'Display help when fly tool and walk tools are selected...

'check if key intercept is enabled,if not enable it.
If Not frmGlbCntrl.GlobeControl.KeyIntercept = 1 Then frmGlbCntrl.GlobeControl.KeyIntercept = 1

Dim puid As UID
Set puid = ToolbarControl.GetItem(index).UID
'uid for fly tool={2C327C42-8CA9-4FC3-8C7B-F6290680FABB}
'uid for walk tool={56C3BDD4-C51A-4574-8954-D3E1F5F54E57}

If puid.Value = "{2C327C42-8CA9-4FC3-8C7B-F6290680FABB}" Then
    'fly...
    lblStatus.Caption = "Use arrow up or arrow left keys to decelerate and arrow up or arrow left keys to accelerate."
    'Fly tool
ElseIf puid.Value = "{56C3BDD4-C51A-4574-8954-D3E1F5F54E57}" Then
    'walk...
    lblStatus.Caption = "Use arrow up or down keys to change elevation and the arrow left or right keys to fine-tune travel speed."
Else
    lblStatus.Caption = ""
End If

  Exit Sub
ErrorHandler:
  HandleError True, "ToolbarControl_OnItemClick " & c_sModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 4
End Sub