Custom scene navigation commands
Fly.vb
' Copyright 2012 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 System.Drawing
Imports ESRI.ArcGIS.Analyst3D
Imports ESRI.ArcGIS.GeomeTry
Imports ESRI.ArcGIS.Controls
Imports ESRI.ArcGIS.ADF.BaseClasses
Imports ESRI.ArcGIS.ADF.CATIDs
Imports System.Runtime.InteropServices

<ComClass(Fly.ClassId, Fly.InterfaceId, Fly.EventsId)> _
Public NotInheritable Class Fly
    Inherits BaseTool

#Region "COM GUIDs"
    ' These  GUIDs provide the COM identity for this class 
    ' and its COM interfaces. If you change them, existing 
    ' clients will no longer be able to access the class.
    Public Const ClassId As String = "C74AE939-B3B1-4F28-9E79-D172CF1F2043"
    Public Const InterfaceId As String = "86B05C26-D3C0-49E9-957D-7F54B35C8940"
    Public Const EventsId As String = "E419FD47-DA90-45B7-8563-BD4D9D023555"
#End Region
#Region "COM Registration Function(s)"
    <ComRegisterFunction(), ComVisibleAttribute(False)> _
    Public Shared Sub RegisterFunction(ByVal registerType As Type)
        ' Required for ArcGIS Component Category Registrar support
        ArcGISCategoryRegistration(registerType)

        'Add any COM registration code after the ArcGISCategoryRegistration() call

    End Sub

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

        'Add any COM unregistration code after the ArcGISCategoryUnregistration() call

    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)
        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)
        ControlsCommands.Unregister(regKey)

    End Sub

#End Region
#End Region
    Declare Function GetClientRect Lib "user32" (ByVal hwnd As Integer, ByRef lpRect As Rectangle) As Integer
    Declare Function SetCursor Lib "user32" (ByVal hCursor As Integer) As Integer

    Private m_pSceneHookHelper As ISceneHookHelper
    Private m_bInUse As Boolean
    Dim bCancel As Boolean = False
    Private m_lMouseX As Long
    Private m_lMouseY As Long
    Private m_dMotion As Double 'speed of the scene fly through in scene units
    Private m_pPointObs As IPoint 'observer
    Private m_pPointTgt As IPoint 'target
    Private m_dDistance As Double 'distance between target and observer
    Private m_dElevation As Double 'normal fly angles in radians
    Private m_dAzimut As Double 'normal fly angles in radians
    Private m_iSpeed As Integer 'speed of a flight
    Private m_flyCur As System.Windows.Forms.Cursor
    Private m_moveFlyCur As System.Windows.Forms.Cursor

  ' A creatable COM class must have a Public Sub New() 
  ' with no parameters, otherwise, the class will not be 
  ' registered in the COM registry and cannot be created 
  ' via CreateObject.
    Public Sub New()
        MyBase.New()

        MyBase.m_category = "Sample_SceneControl(VB.NET)"
        MyBase.m_caption = "Fly"
        MyBase.m_toolTip = "Fly"
        MyBase.m_name = "Sample_SceneControl(VB.NET)/Fly"
        MyBase.m_message = "Flies through the scene"

        'Load resources
        Dim res() As String = GetType(Fly).Assembly.GetManifestResourceNames()
        If res.GetLength(0) > 0 Then
            MyBase.m_bitmap = New System.Drawing.Bitmap(GetType(Fly).Assembly.GetManifestResourceStream("SceneToolsVB.fly.bmp"))
        End If
        m_flyCur = New System.Windows.Forms.Cursor(GetType(Fly).Assembly.GetManifestResourceStream("SceneToolsVB.fly.cur"))
        m_moveFlyCur = New System.Windows.Forms.Cursor(GetType(Fly).Assembly.GetManifestResourceStream("SceneToolsVB.fly1.cur"))
        m_pSceneHookHelper = New SceneHookHelperClass
        m_iSpeed = 0
    End Sub

    Public Overrides Sub OnCreate(ByVal hook As Object)
        m_pSceneHookHelper.Hook = hook
    End Sub

    Public Overrides ReadOnly Property Enabled() As Boolean
        Get
            'Disable if orthographic (2D) view
            If m_pSceneHookHelper.Hook Is Nothing Or m_pSceneHookHelper.Scene Is Nothing Then
                Return False
            Else
                Dim pCamera As ICamera = CType(m_pSceneHookHelper.Camera, ICamera)
                If pCamera.ProjectionType = esri3DProjectionType.esriOrthoProjection Then
                    Return False
                Else
                    Return True
                End If
            End If
        End Get
    End Property

    Public Overrides ReadOnly Property Cursor() As Integer
        Get
            If (m_bInUse) Then
                Return m_moveFlyCur.Handle.ToInt32()
            Else
                Return m_flyCur.Handle.ToInt32()
            End If
        End Get
    End Property

    Public Overrides Function Deactivate() As Boolean
        Return True
    End Function

    Public Overrides Sub OnMouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)
        If (Not m_bInUse) Then
            m_lMouseX = X
            m_lMouseY = Y

            If (m_iSpeed = 0) Then
                StartFlight()
            End If
        Else
            'Set the speed
            If (Button = 1) Then
                m_iSpeed += 1
            ElseIf (Button = 2) Then
                m_iSpeed -= 1
            End If

            'Start or end the flight
            If (m_iSpeed = 0) Then
                EndFlight()
            Else
                StartFlight()
            End If
        End If
    End Sub

    Public Overrides Sub OnMouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)
        If (Not m_bInUse) Then
            Return
        End If
        m_lMouseX = X
        m_lMouseY = Y
    End Sub

    Public Overrides Sub OnKeyUp(ByVal keyCode As Integer, ByVal Shift As Integer)
        If (m_bInUse) Then
            'Slow down the speed of the fly through
            If (keyCode = 40 Or keyCode = 37) Then
                m_dMotion = m_dMotion / 2
                'Speed up the speed of the fly through
            ElseIf (keyCode = 38 Or keyCode = 39) Then
                m_dMotion = m_dMotion * 2
            End If
        End If
    End Sub

    Public Sub StartFlight()
        m_bInUse = True

        'Get the extent of the scene graph
        Dim pEnvelope As IEnvelope
        pEnvelope = m_pSceneHookHelper.SceneGraph.Extent

        If (pEnvelope.IsEmpty) Then
            Return
        End If

        'Query the coordinates of the extent
        Dim dXmin, dXmax, dYmin, dYmax As Double
        pEnvelope.QueryCoords(dXmin, dYmin, dXmax, dYmax)

        'Set the speed of the scene
        If ((dXmax - dXmin) > (dYmax - dYmin)) Then
            m_dMotion = (dXmax - dXmin) / 100
        Else
            m_dMotion = (dYmax - dYmin) / 100
        End If

        'Get camera's current observer and target
        Dim pCamera As ICamera = CType(m_pSceneHookHelper.Camera, ICamera)
        m_pPointObs = pCamera.Observer
        m_pPointTgt = pCamera.Target

        'Get the differences between the observer and target
        Dim dx, dy, dz As Double
        dx = m_pPointTgt.X - m_pPointObs.X
        dy = m_pPointTgt.Y - m_pPointObs.Y
        dz = m_pPointTgt.Z - m_pPointObs.Z

        'Determine the elevation and azimuth in radians and
        'the distance between the target and observer
        m_dElevation = Math.Atan(dz / Math.Sqrt(dx * dx + dy * dy))
        m_dAzimut = Math.Atan(dy / dx)
        m_dDistance = Math.Sqrt((dx * dx) + (dy * dy) + (dz * dz))

        'Windows API call to set cursor
        SetCursor(m_moveFlyCur.Handle.ToInt32())

        'Continue the flight
        Flight()

    End Sub

    Public Sub Flight()
        'Get IMessageDispatcher interface
        Dim pMessageDispatcher As IMessageDispatcher
        pMessageDispatcher = New MessageDispatcherClass

        'Set the ESC key to be seen as a cancel action
        pMessageDispatcher.CancelOnClick = False
        pMessageDispatcher.CancelOnEscPress = True

        'Get the scene graph
        Dim pSceneGraph As ISceneGraph = CType(m_pSceneHookHelper.SceneGraph, ISceneGraph)

        'Get the scene viewer
        Dim pSceneViewer As ISceneViewer = CType(m_pSceneHookHelper.ActiveViewer, ISceneViewer)

        'Get the camera
        Dim pCamera As ICamera = CType(m_pSceneHookHelper.Camera, ICamera)

        bCancel = False

        Do
            'Get the elapsed time
            Dim dlastFrameDuration, dMeanFrameRate As Double
            pSceneGraph.GetDrawingTimeInfo(dlastFrameDuration, dMeanFrameRate)

            If (dlastFrameDuration < 0.01) Then
                dlastFrameDuration = 0.01
            End If

            If (dlastFrameDuration > 1) Then
                dlastFrameDuration = 1
            End If

            'Windows API call to get windows client coordinates
            Dim rect As Rectangle
            rect = New Rectangle

            If (GetClientRect(m_pSceneHookHelper.ActiveViewer.hWnd, rect) = 0) Then
                Return
            End If

            'Get normal vectors
            Dim dXMouseNormal, dYMouseNormal As Double
            dXMouseNormal = 2 * (m_lMouseX / rect.Right) - 1 'should be double
            dYMouseNormal = 2 * (m_lMouseY / rect.Bottom) - 1

            'Set elevation and azimuth in radians for normal rotation
            m_dElevation = m_dElevation - (dlastFrameDuration * dYMouseNormal * Math.Abs(dYMouseNormal))
            m_dAzimut = m_dAzimut - (dlastFrameDuration * dXMouseNormal * Math.Abs(dXMouseNormal))

            If (m_dElevation > 0.45 * 3.141592) Then
                m_dElevation = 0.45 * 3.141592
            End If

            If (m_dElevation < -0.45 * 3.141592) Then
                m_dElevation = -0.45 * 3.141592
            End If

            If (m_dAzimut < 0) Then
                m_dAzimut = m_dAzimut + (2 * 3.141592)
            End If

            If (m_dAzimut > 2 * 3.141592) Then
                m_dAzimut = m_dAzimut - (2 * 3.141592)
            End If

            Dim dx, dy, dz As Double

            dx = Math.Cos(m_dElevation) * Math.Cos(m_dAzimut)
            dy = Math.Cos(m_dElevation) * Math.Sin(m_dAzimut)
            dz = Math.Sin(m_dElevation)

            'Change the viewing directions (target)
            m_pPointTgt.X = m_pPointObs.X + (m_dDistance * dx)
            m_pPointTgt.Y = m_pPointObs.Y + (m_dDistance * dy)
            m_pPointTgt.Z = m_pPointObs.Z + (m_dDistance * dz)

            'Move the camera in the viewing directions
            m_pPointObs.X = m_pPointObs.X + (dlastFrameDuration * (2 ^ m_iSpeed) * m_dMotion * dx)
            m_pPointObs.Y = m_pPointObs.Y + (dlastFrameDuration * (2 ^ m_iSpeed) * m_dMotion * dy)
            m_pPointTgt.X = m_pPointTgt.X + (dlastFrameDuration * (2 ^ m_iSpeed) * m_dMotion * dx)
            m_pPointTgt.Y = m_pPointTgt.Y + (dlastFrameDuration * (2 ^ m_iSpeed) * m_dMotion * dy)
            m_pPointObs.Z = m_pPointObs.Z + (dlastFrameDuration * (2 ^ m_iSpeed) * m_dMotion * dz)
            m_pPointTgt.Z = m_pPointTgt.Z + (dlastFrameDuration * (2 ^ m_iSpeed) * m_dMotion * dz)

            pCamera.Observer = m_pPointObs
            pCamera.Target = m_pPointTgt

            'Set the angle of the camera about the line of sight between the observer and target
            pCamera.RollAngle = 10 * dXMouseNormal * Math.Abs(dXMouseNormal)

            'Redraw the scene viewer 
            pSceneViewer.Redraw(True)

            Dim objCancel As Object = Nothing

            'Dispatch any waiting messages: OnMouseMove / OnMouseUp / OnKeyUp events
            'object objCancel = bCancel as object;
            pMessageDispatcher.Dispatch(m_pSceneHookHelper.ActiveViewer.hWnd, False, objCancel)

            'End flight if ESC key pressed
            If (bCancel = True) Then
                EndFlight()
            End If
        Loop While m_bInUse = True And bCancel = False

        SetCursor(m_flyCur.Handle.ToInt32())
        bCancel = False

    End Sub

    Public Sub EndFlight()
        m_bInUse = False

        'Get the scene graph
        Dim pSceneGraph As ISceneGraph = CType(m_pSceneHookHelper.SceneGraph, ISceneGraph)

        Dim pPointTgt As IPoint
        pPointTgt = New PointClass
        Dim pOwner As Object = Nothing, pObject As Object = Nothing
        Dim rect As Rectangle
        rect = New Rectangle

        'Windows API call to get windows client coordinates
        If (GetClientRect(m_pSceneHookHelper.ActiveViewer.hWnd, rect) <> 0) Then
            'Translate coordinates into a 3D point
            pSceneGraph.Locate(pSceneGraph.ActiveViewer, rect.Right / 2, rect.Bottom / 2, esriScenePickMode.esriScenePickAll, True, pPointTgt, pOwner, pObject)
        End If

        'Get the camera
        Dim pCamera As ICamera = CType(m_pSceneHookHelper.Camera, ICamera)

        If (Not pPointTgt Is Nothing) Then
            'Reposition target and observer
            pCamera.Target = pPointTgt
            pCamera.Observer = m_pPointObs
        End If

        'Set the angle of the camera about the line
        'of sight between the observer and target
        pCamera.RollAngle = 0
        pCamera.PropertiesChanged()

        'Windows API call to set cursor
        SetCursor(m_moveFlyCur.Handle.ToInt32())
        m_iSpeed = 0

    End Sub

    Public Overrides Sub OnKeyDown(ByVal keyCode As Integer, ByVal Shift As Integer)
        If (keyCode = 27) Then 'ESC is pressed
            bCancel = True
        End If
    End Sub
End Class