3D dynamic element tracking
TrackDynamicObject.vb
' Copyright 2010 ESRI
' 
' All rights reserved under the copyright laws of the United States
' and applicable international laws, treaties, and conventions.
' 
' You may freely redistribute and use this sample code, with or
' without modification, provided you include the original copyright
' notice and use restrictions.
' 
' See the use restrictions.
' 

Imports Microsoft.VisualBasic
Imports System
Imports System.Drawing
Imports System.Runtime.InteropServices
Imports Microsoft.Win32
Imports ESRI.ArcGIS.ADF.BaseClasses
Imports ESRI.ArcGIS.ADF.CATIDs
Imports ESRI.ArcGIS.Carto
Imports ESRI.ArcGIS.DataSourcesFile
Imports ESRI.ArcGIS.Display
Imports ESRI.ArcGIS.esriSystem
Imports ESRI.ArcGIS.Geodatabase
Imports ESRI.ArcGIS.Geometry
Imports ESRI.ArcGIS.SystemUI
Imports ESRI.ArcGIS.GlobeCore
Imports ESRI.ArcGIS.Controls
Imports ESRI.ArcGIS.Analyst3D

''' <summary>
''' This command demonstrates tracking dynamic object in ArcGlobe/GlobeControl with the camera
''' </summary>
<Guid("DCB871A1-390A-456f-8A0D-9FDB6A20F721"), ClassInterface(ClassInterfaceType.None), ProgId("GlobeControlApp.TrackDynamicObject")> _
Public NotInheritable Class TrackDynamicObject : Inherits BaseCommand : Implements IDisposable
#Region "COM Registration Function(s)"
  <ComRegisterFunction(), ComVisible(False)> _
  Private Shared Sub RegisterFunction(ByVal registerType As Type)
    ' Required for ArcGIS Component Category Registrar support
    ArcGISCategoryRegistration(registerType)

    '
    ' TODO: Add any COM registration code here
    ''
  End Sub

  <ComUnregisterFunction(), ComVisible(False)> _
  Private Shared Sub UnregisterFunction(ByVal registerType As Type)
    ' Required for ArcGIS Component Category Registrar support
    ArcGISCategoryUnregistration(registerType)

    '
    ' TODO: Add any COM unregistration code here
    ''
  End Sub

#Region "ArcGIS Component Category Registrar generated code"
  ''' <summary>
  ''' Required method for ArcGIS Component Category registration -
  ''' Do not modify the contents of this method with the code editor.
  ''' </summary>
  Private Shared Sub ArcGISCategoryRegistration(ByVal registerType As Type)
    Dim regKey As String = String.Format("HKEY_CLASSES_ROOT\CLSID\{{{0}}}", registerType.GUID)
    GMxCommands.Register(regKey)
    ControlsCommands.Register(regKey)

  End Sub
  ''' <summary>
  ''' Required method for ArcGIS Component Category unregistration -
  ''' Do not modify the contents of this method with the code editor.
  ''' </summary>
  Private Shared Sub ArcGISCategoryUnregistration(ByVal registerType As Type)
    Dim regKey As String = String.Format("HKEY_CLASSES_ROOT\CLSID\{{{0}}}", registerType.GUID)
    GMxCommands.Unregister(regKey)
    ControlsCommands.Unregister(regKey)

  End Sub

#End Region
#End Region

  'class members
  Private m_globeHookHelper As IGlobeHookHelper = Nothing
  Private m_globeDisplay As IGlobeDisplay = Nothing
  Private m_sceneViwer As ISceneViewer = Nothing
  Private m_globeGraphicsLayer As IGlobeGraphicsLayer = Nothing
  Private m_realTimeFeedManager As IRealTimeFeedManager = Nothing
  Private m_realTimeFeed As IRealTimeFeed = Nothing
  Private m_bConnected As Boolean = False
  Private m_bTrackAboveTarget As Boolean = True
  Private m_once As Boolean = True
  Private m_trackObjectIndex As Integer = -1
  Private m_shapefileName As String = String.Empty


#Region "class constructor"

  ''' <summary>
  ''' Class Ctor
  ''' </summary>
  Public Sub New()
    MyBase.m_category = ".NET Samples"
    MyBase.m_caption = "Track Dynamic Object"
    MyBase.m_message = "Tracking a dynamic object"
    MyBase.m_toolTip = "Track Dynamic Object"
    MyBase.m_name = MyBase.m_category & "_" & MyBase.m_caption

    Try
      Dim bitmapResourceName As String = Me.GetType().Name & ".bmp"
      MyBase.m_bitmap = New Bitmap(Me.GetType(), bitmapResourceName)
    Catch ex As Exception
      System.Diagnostics.Trace.WriteLine(ex.Message, "Invalid Bitmap")
    End Try
  End Sub
#End Region

#Region "Overridden Class Methods"

  ''' <summary>
  ''' Occurs when this command is created
  ''' </summary>
  ''' <param name="hook">Instance of the application</param>
  Public Overrides Sub OnCreate(ByVal hook As Object)
    'initialize the hook-helper
    If m_globeHookHelper Is Nothing Then
      m_globeHookHelper = New GlobeHookHelper()
    End If

    'set the hook
    m_globeHookHelper.Hook = hook

    'connect to the ZipCodes featureclass
    'get the ArcGIS path from the registry
    Dim key As RegistryKey = Registry.LocalMachine.OpenSubKey("SOFTWARE\ESRI\ArcObjectsSDK10.0")
    Dim path As String = Convert.ToString(key.GetValue("InstallDir"))

    'set the path to the featureclass used by the GPS simulator
    m_shapefileName = System.IO.Path.Combine(path, "Samples\\data\\USAMajorHighways\\usa_major_highways.shp")

    'get the GlobeDisplsy from the hook helper
    m_globeDisplay = m_globeHookHelper.GlobeDisplay

    'initialize the real-time manager
    If Nothing Is m_realTimeFeedManager Then
      m_realTimeFeedManager = New RealTimeFeedManagerClass()
    End If

    'use the built in simulator of the real-time manager
    m_realTimeFeedManager.RealTimeFeed = TryCast(m_realTimeFeedManager.RealTimeFeedSimulator, IRealTimeFeed)

    'keep a reference to the RealTimeManager in order to prevent the garbage collector to try and dispose it
    m_realTimeFeed = m_realTimeFeedManager.RealTimeFeed
  End Sub

  ''' <summary>
  ''' Occurs when this command is clicked
  ''' </summary>
  Public Overrides Sub OnClick()
    Try

      If (Not m_bConnected) Then
        'show the tracking type selection dialog (whether to track the element from above or follow it from behind)
        Dim dlg As TrackSelectionDlg = New TrackSelectionDlg()
        If System.Windows.Forms.DialogResult.OK <> dlg.ShowDialog() Then
          Return
        End If

        'get the required tracking mode
        m_bTrackAboveTarget = dlg.UseOrthoTrackingMode

        'do only once initializations
        If m_once Then
          'create the graphics layer to manage the dynamic object
          m_globeGraphicsLayer = New GlobeGraphicsLayerClass()
          CType(m_globeGraphicsLayer, ILayer).Name = "DynamicObjects"

          Dim scene As IScene = CType(m_globeDisplay.Globe, IScene)

          'add the new graphic layer to the globe
          scene.AddLayer(CType(m_globeGraphicsLayer, ILayer), False)

          'activate the graphics layer
          scene.ActiveGraphicsLayer = CType(m_globeGraphicsLayer, ILayer)

          'open a polyline featurelayer that would serve the real-time feed GPS simulator
          Dim featureLayer As IFeatureLayer = GetFeatureLayer()
          If featureLayer Is Nothing Then
            Return
          End If

          'assign the featurelayer to the GPS simulator
          m_realTimeFeedManager.RealTimeFeedSimulator.FeatureLayer = featureLayer

          m_once = False
        End If

        'get the GlobeViewUtil which is needed for coordinate transformations
        m_sceneViwer = m_globeDisplay.ActiveViewer

        'Set the globe mode to terrain mode, since otherwise it will not be possible to set the target position
        CType(m_sceneViwer.Camera, IGlobeCamera).OrientationMode = esriGlobeCameraOrientationMode.esriGlobeCameraOrientationLocal

        'set the simulator elapsed time
        m_realTimeFeedManager.RealTimeFeedSimulator.TimeIncrement = 0.1 'sec

        'wire the real-time feed PositionUpdate event
        AddHandler (CType(m_realTimeFeed, IRealTimeFeedEvents_Event)).PositionUpdated, AddressOf OnPositionUpdated

        'start the real-time listener
        m_realTimeFeed.Start()
      Else
        'stop the real-time listener
        m_realTimeFeed.Stop()

        'unhook the PositionUpdated event handler
        RemoveHandler (CType(m_realTimeFeed, IRealTimeFeedEvents_Event)).PositionUpdated, AddressOf TrackDynamicObject_PositionUpdated
      End If

      'switch the connection flag
      m_bConnected = Not m_bConnected
    Catch ex As Exception
      System.Diagnostics.Trace.WriteLine(ex.Message)
    End Try
  End Sub

  ''' <summary>
  ''' The Checked property indicates the state of this Command. 
  ''' </summary>
  ''' <remarks>If a command item appears depressed on a commandbar, the command is checked.</remarks>
  Public Overrides ReadOnly Property Checked() As Boolean
    Get
      Return m_bConnected
    End Get
  End Property

#End Region

#Region "helper methods"

  ''' <summary>
  ''' get a featurelayer that would be used by the real-time simulator
  ''' </summary>
  ''' <returns></returns>
  Private Function GetFeatureLayer() As IFeatureLayer
    'instantiate a new featurelayer
    Dim featureLayer As IFeatureLayer = New FeatureLayerClass()

    'set the layer's name
    featureLayer.Name = "GPS Data"

    'open the featureclass
    Dim featureClass As IFeatureClass = OpenFeatureClass()
    If featureClass Is Nothing Then
      Return Nothing
    End If

    'set the featurelayer featureclass
    featureLayer.FeatureClass = featureClass

    'return the featurelayer
    Return featureLayer
  End Function

  ''' <summary>
  ''' Opens a shapefile polyline featureclass
  ''' </summary>
  ''' <returns></returns>
  Private Function OpenFeatureClass() As IFeatureClass
    Dim path As String = System.IO.Path.GetDirectoryName(m_shapefileName)
    Dim fileName As String = System.IO.Path.GetFileNameWithoutExtension(m_shapefileName)
    'instantiate a new workspace factory
    Dim workspaceFactory As IWorkspaceFactory = New ShapefileWorkspaceFactoryClass()

    'open the workspace containing the featureclass
    Dim featureWorkspace As IFeatureWorkspace = TryCast(workspaceFactory.OpenFromFile(path, 0), IFeatureWorkspace)

    'open the featureclass
    Dim featureClass As IFeatureClass = featureWorkspace.OpenFeatureClass(fileName)

    'make sure that the featureclass type is polyline
    If featureClass.ShapeType <> esriGeometryType.esriGeometryPolyline Then
      featureClass = Nothing
    End If

    'return the featureclass
    Return featureClass
  End Function

  ''' <summary>
  ''' Adds a sphere element to the given graphics layer at the specified position
  ''' </summary>
  ''' <param name="globeGraphicsLayer"></param>
  ''' <param name="position"></param>
  ''' <returns></returns>
  Private Function AddTrackElement(ByVal globeGraphicsLayer As IGlobeGraphicsLayer, ByVal position As esriGpsPositionInfo) As Integer
    If Nothing Is globeGraphicsLayer Then
      Return -1
    End If

    'create a new point at the given position
    Dim point As IPoint = New PointClass()
    CType(point, IZAware).ZAware = True
    point.X = position.longitude
    point.Y = position.latitude
    point.Z = 0.0

    'set the color for the element (red)
    Dim color As IRgbColor = New RgbColorClass()
    color.Red = 255
    color.Green = 0
    color.Blue = 0

    'create a new 3D marker symbol
    Dim markerSymbol As IMarkerSymbol = New SimpleMarker3DSymbolClass()

    'set the marker symbol's style and resolution
    CType(markerSymbol, ISimpleMarker3DSymbol).Style = esriSimple3DMarkerStyle.esriS3DMSSphere
    CType(markerSymbol, ISimpleMarker3DSymbol).ResolutionQuality = 1.0

    'set the symbol's size and color
    markerSymbol.Size = 700
    markerSymbol.Color = TryCast(color, IColor)

    'crate the graphic element
    Dim trackElement As IElement = New MarkerElementClass()

    'set the element's symbol and geometry (location and shape)
    CType(trackElement, IMarkerElement).Symbol = markerSymbol
    trackElement.Geometry = TryCast(point, IPoint)


    'add the element to the graphics layer
    Dim elemIndex As Integer = 0
    CType(globeGraphicsLayer, IGraphicsContainer).AddElement(trackElement, 0)

    'get the element's index
    globeGraphicsLayer.FindElementIndex(trackElement, elemIndex)
    Return elemIndex
  End Function

  ''' <summary>
  ''' The real-time feed position updated event handler
  ''' </summary>
  ''' <param name="position">a GPS position information</param>
  ''' <param name="estimate">indicates whether this is an estimated time or real time</param>
  Private Sub OnPositionUpdated(ByRef position As esriGpsPositionInfo, ByVal estimate As Boolean)
    Try
      'add the tracking element to the tracking graphics layer (should happen only once)
      If -1 = m_trackObjectIndex Then
        Dim index As Integer = AddTrackElement(m_globeGraphicsLayer, position)
        If -1 = index Then
          Throw New Exception("could not add tracking object")
        End If

        'cache the element's index
        m_trackObjectIndex = index

        Return
      End If
      'get the element by its index
      Dim elem As IElement = (CType(m_globeGraphicsLayer, IGraphicsContainer3D)).Element(m_trackObjectIndex)

      'keep the previous location
      Dim lat, lon, alt As Double
      CType(elem.Geometry, IPoint).QueryCoords(lon, lat)
      alt = (CType(elem.Geometry, IPoint)).Z

      'update the element's position
      Dim point As IPoint = TryCast(elem.Geometry, IPoint)
      point.X = position.longitude
      point.Y = position.latitude
      point.Z = alt
      elem.Geometry = CType(point, IGeometry)

      'update the element in the graphics layer.
      SyncLock m_globeGraphicsLayer
        m_globeGraphicsLayer.UpdateElementByIndex(m_trackObjectIndex)
      End SyncLock

      Dim globeCamera As IGlobeCamera = TryCast(m_sceneViwer.Camera, IGlobeCamera)

      'set the camera position in order to track the element
      If m_bTrackAboveTarget Then
        TrackAboveTarget(globeCamera, point)
      Else
        TrackFollowTarget(globeCamera, point.X, point.Y, point.Z, lon, lat, alt)
      End If

    Catch ex As Exception
      System.Diagnostics.Trace.WriteLine(ex.Message)
    End Try
  End Sub
  Private Sub TrackDynamicObject_PositionUpdated(ByRef position As esriGpsPositionInfo, ByVal estimate As Boolean)

  End Sub

  ''' <summary>
  ''' If the user chose to track the element from behind, set the camera behind the element 
  ''' so that the camera will be placed on the line connecting the previous and the current element's position.
  ''' </summary>
  ''' <param name="globeCamera"></param>
  ''' <param name="newLon"></param>
  ''' <param name="newLat"></param>
  ''' <param name="newAlt"></param>
  ''' <param name="oldLon"></param>
  ''' <param name="oldLat"></param>
  ''' <param name="oldAlt"></param>
  Private Sub TrackFollowTarget(ByVal globeCamera As IGlobeCamera, ByVal newLon As Double, ByVal newLat As Double, ByVal newAlt As Double, ByVal oldLon As Double, ByVal oldLat As Double, ByVal oldAlt As Double)
    'make sure that the camera position is not directly above the element. Otherwise it can lead to
    'an ill condition
    If newLon = oldLon AndAlso newLat = oldLat Then
      newLon += 0.00001
      newLat += 0.00001
    End If

    'calculate the azimuth from the previous position to the current position
    Dim azimuth As Double = Math.Atan2(newLat - oldLat, newLon - oldLon) * (Math.PI / 180.0)

    'the camera new position, right behind the element
    Dim obsX As Double = newLon - 0.04 * Math.Cos(azimuth * (Math.PI / 180))
    Dim obsY As Double = newLat - 0.04 * Math.Sin(azimuth * (Math.PI / 180))

    'set the camera position. The camera must be locked in order to prevent a dead-lock caused by the cache manager
    SyncLock globeCamera
      globeCamera.SetTargetLatLonAlt(newLat, newLon, newAlt / 1000.0)
      globeCamera.SetObserverLatLonAlt(obsY, obsX, newAlt / 1000.0 + 0.7)
      m_sceneViwer.Camera.Apply()
    End SyncLock

    'refresh the globe display
    m_globeDisplay.RefreshViewers()
  End Sub

  ''' <summary>
  ''' should the user choose to track the element from above, set the camera above the element
  ''' </summary>
  ''' <param name="globeCamera"></param>
  ''' <param name="objectLocation"></param>
  Private Sub TrackAboveTarget(ByVal globeCamera As IGlobeCamera, ByVal objectLocation As IPoint)
    'Update the observer as well as the camera position
    'The camera must be locked in order to prevent a dead-lock caused by the cache manager
    SyncLock globeCamera

      globeCamera.SetTargetLatLonAlt(objectLocation.Y, objectLocation.X, objectLocation.Z / 1000.0)

      'The camera must nut be located exactly above the target, since it results in poor orientation computation
      'and therefore the camera gets jumpy.
      globeCamera.SetObserverLatLonAlt(objectLocation.Y - 0.000001, objectLocation.X - 0.000001, objectLocation.Z / 1000.0 + 30.0)
      m_sceneViwer.Camera.Apply()
    End SyncLock
    m_globeDisplay.RefreshViewers()
  End Sub

#End Region

#Region "IDisposable Members"

  Public Sub Dispose() Implements IDisposable.Dispose

  End Sub

#End Region
End Class