Navigate.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(Navigate.ClassId, Navigate.InterfaceId, Navigate.EventsId)> _ Public NotInheritable Class Navigate 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 = "E4BDFC47-0845-4DF1-B4B4-637EF86C299A" Public Const InterfaceId As String = "12F31942-BCB1-487C-9790-DB497983B5C7" Public Const EventsId As String = "2D9B12D3-59E9-4C0E-8218-FBD220446757" #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 GetCapture Lib "user32" (ByVal fuFlags As Integer) As Integer Declare Function SetCapture Lib "user32" (ByVal hwnd As Integer) As Integer Declare Function SetCursor Lib "user32" (ByVal hCursor As Integer) As Integer Declare Function ReleaseCapture Lib "user32" (ByVal hwnd As Integer) As Integer Private m_pSceneHookHelper As ISceneHookHelper Private m_bInUse As Boolean Private m_bGesture As Boolean Private bCancel As Boolean = False Private m_lMouseX, m_lMouseY As Long Private m_bSpinning As Boolean Private m_dSpinStep As Double Private m_pCursorNav As System.Windows.Forms.Cursor Private m_pCursorPan As System.Windows.Forms.Cursor Private m_pCursorZoom As System.Windows.Forms.Cursor Private m_pCursorGest 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 = "Navigate" MyBase.m_toolTip = "Navigate" MyBase.m_name = "Sample_SceneControl(VB.NET)/Navigate" MyBase.m_message = "Navigates the scene" 'Load resources Dim res() As String = GetType(Navigate).Assembly.GetManifestResourceNames() If res.GetLength(0) > 0 Then MyBase.m_bitmap = New System.Drawing.Bitmap(GetType(Navigate).Assembly.GetManifestResourceStream("SceneToolsVB.Navigation.bmp")) End If m_pCursorNav = New System.Windows.Forms.Cursor(GetType(Navigate).Assembly.GetManifestResourceStream("SceneToolsVB.navigation.cur")) m_pCursorPan = New System.Windows.Forms.Cursor(GetType(Navigate).Assembly.GetManifestResourceStream("SceneToolsVB.movehand.cur")) m_pCursorZoom = New System.Windows.Forms.Cursor(GetType(Navigate).Assembly.GetManifestResourceStream("SceneToolsVB.ZOOMINOUT.CUR")) m_pCursorGest = New System.Windows.Forms.Cursor(GetType(Navigate).Assembly.GetManifestResourceStream("SceneToolsVB.gesture.cur")) m_pSceneHookHelper = New SceneHookHelperClass End Sub Public Overrides Sub OnCreate(ByVal hook As Object) m_pSceneHookHelper.Hook = hook If (Not m_pSceneHookHelper Is Nothing) Then m_bGesture = m_pSceneHookHelper.ActiveViewer.GestureEnabled m_bSpinning = False End If 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_bGesture = True) Then Return m_pCursorGest.Handle.ToInt32() Else Return m_pCursorNav.Handle.ToInt32() End If End Get End Property Public Overrides Function Deactivate() As Boolean Return True End Function Public Overrides Sub OnMouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer) If (Button = 3) Then bCancel = True Else m_bInUse = True SetCapture(m_pSceneHookHelper.ActiveViewer.hWnd) m_lMouseX = X m_lMouseY = Y 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 (m_bInUse = False) Then Return End If If (X - m_lMouseX = 0 And Y - m_lMouseY = 0) Then Return End If Dim dx, dy As Long dx = X - m_lMouseX dy = Y - m_lMouseY 'If right mouse clicked If (Button = 2) Then 'Set the zoom cursor SetCursor(m_pCursorZoom.Handle.ToInt32()) If (dy < 0) Then m_pSceneHookHelper.Camera.Zoom(1.1) ElseIf (dy > 0) Then m_pSceneHookHelper.Camera.Zoom(0.9) End If End If 'If two mouse buttons clicked If (Button = 3) Then 'Set the pan cursor SetCursor(m_pCursorPan.Handle.ToInt32()) 'Create a point with previous mouse coordinates Dim pStartPoint As IPoint pStartPoint = New PointClass pStartPoint.PutCoords(m_lMouseX, m_lMouseY) 'Create point with a new mouse coordinates Dim pEndPoint As IPoint pEndPoint = New PointClass pEndPoint.PutCoords(X, Y) 'Pan camera m_pSceneHookHelper.Camera.Pan(pStartPoint, pEndPoint) End If 'If left mouse clicked If (Button = 1) Then 'If scene viewer gesturing is disabled move the camera observer If (m_bGesture = False) Then m_pSceneHookHelper.Camera.PolarUpdate(1, dx, dy, True) Else 'If camera already spinning If (m_bSpinning = True) Then 'Move the camera observer m_pSceneHookHelper.Camera.PolarUpdate(1, dx, dy, True) Else 'Windows API call to get windows client coordinates Dim rect As Rectangle rect = New Rectangle GetClientRect(m_pSceneHookHelper.ActiveViewer.hWnd, rect) 'Recalculate the spin step If (dx < 0) Then m_dSpinStep = (180.0 / rect.Right - rect.Left) * (dx - m_pSceneHookHelper.ActiveViewer.GestureSensitivity) Else m_dSpinStep = (180.0 / rect.Right - rect.Left) * (dx + m_pSceneHookHelper.ActiveViewer.GestureSensitivity) End If 'Start spinning StartSpin() End If End If End If 'Set Mouse coordinates for the next 'OnMouse Event m_lMouseX = X m_lMouseY = Y 'Redraw the scene viewer m_pSceneHookHelper.ActiveViewer.Redraw(True) End Sub Public Sub StartSpin() m_bSpinning = True '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 Do 'Move the camera observer m_pSceneHookHelper.Camera.PolarUpdate(1, m_dSpinStep, 0, True) 'Redraw the scene viewer m_pSceneHookHelper.ActiveViewer.Redraw(True) 'Dispatch any waiting messages: OnMouseMove/ OnMouseDown/ OnKeyUp/ OnKeyDown events Dim b_oCancel As Object = Nothing pMessageDispatcher.Dispatch(m_pSceneHookHelper.ActiveViewer.hWnd, False, b_oCancel) If (bCancel = True) Then m_bSpinning = False End If Loop While (bCancel = False) bCancel = False End Sub Public Overrides Sub OnKeyDown(ByVal keyCode As Integer, ByVal Shift As Integer) If (keyCode = 27) Then bCancel = True SetCursor(m_pCursorNav.Handle.ToInt32()) End If Select Case Shift Case 1 'Shift key SetCursor(m_pCursorPan.Handle.ToInt32()) Case 2 'Control key SetCursor(m_pCursorZoom.Handle.ToInt32()) Case 3 'shift + control key 'Set scene viewer gesture enabled property If (m_bSpinning = False) Then If (m_bGesture = True) Then m_pSceneHookHelper.ActiveViewer.GestureEnabled = False m_bGesture = False SetCursor(m_pCursorNav.Handle.ToInt32()) Else m_pSceneHookHelper.ActiveViewer.GestureEnabled = True m_bGesture = True SetCursor(m_pCursorGest.Handle.ToInt32()) End If End If Case Else Return End Select End Sub Public Overrides Sub OnKeyUp(ByVal keyCode As Integer, ByVal Shift As Integer) If (Shift = 1) Then 'Pan the camera Select Case keyCode Case 38 'Up key m_pSceneHookHelper.Camera.Move(esriCameraMovementType.esriCameraMoveDown, 0.01) Case 40 ' Down key m_pSceneHookHelper.Camera.Move(esriCameraMovementType.esriCameraMoveUp, 0.01) Case 37 'Left key m_pSceneHookHelper.Camera.Move(esriCameraMovementType.esriCameraMoveRight, 0.01) Case 39 'Right key m_pSceneHookHelper.Camera.Move(esriCameraMovementType.esriCameraMoveLeft, 0.01) Case Else Return End Select ElseIf (Shift = 2) Then 'Control key 'Move camera in/out or turn camera around the observer Select Case keyCode Case 38 m_pSceneHookHelper.Camera.Move(esriCameraMovementType.esriCameraMoveAway, 0.01) Case 40 m_pSceneHookHelper.Camera.Move(esriCameraMovementType.esriCameraMoveToward, 0.01) Case 37 m_pSceneHookHelper.Camera.HTurnAround(-1) Case 39 m_pSceneHookHelper.Camera.HTurnAround(1) Case Else Return End Select Else Dim d, dAltitude, dAzimuth As Double d = 5 dAltitude = 2 dAzimuth = 2 'Move the camera observer by the given polar 'increments or increase/decrease the spin speed Select Case keyCode Case 38 m_pSceneHookHelper.Camera.PolarUpdate(1, 0, -dAltitude * d, True) Case 40 m_pSceneHookHelper.Camera.PolarUpdate(1, 0, dAltitude * d, True) Case 37 m_pSceneHookHelper.Camera.PolarUpdate(1, dAzimuth * d, 0, True) Case 39 m_pSceneHookHelper.Camera.PolarUpdate(1, -dAzimuth * d, 0, True) Case 33 ' Page up m_dSpinStep = m_dSpinStep * 1.1 Case 34 ' Page down m_dSpinStep = m_dSpinStep / 1.1 Case Else Return End Select End If 'Set the navigation cursor If (m_bGesture = True) Then SetCursor(m_pCursorGest.Handle.ToInt32()) Else SetCursor(m_pCursorNav.Handle.ToInt32()) End If 'Redraw the scene viewer m_pSceneHookHelper.ActiveViewer.Redraw(True) End Sub Public Overrides Sub OnMouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer) 'Set the navigation cursor If (m_bGesture = True) Then SetCursor(m_pCursorGest.Handle.ToInt32()) Else SetCursor(m_pCursorNav.Handle.ToInt32()) End If If (GetCapture(m_pSceneHookHelper.ActiveViewer.hWnd) <> 0) Then ReleaseCapture(m_pSceneHookHelper.ActiveViewer.hWnd) End If End Sub End Class