Snapping を使用したスナップ

Imports System.Runtime.InteropServices
Imports System.Drawing
Imports ESRI.ArcGIS.ADF.BaseClasses
Imports ESRI.ArcGIS.ADF.CATIDs
Imports ESRI.ArcGIS.Controls
Imports System.Windows.Forms
Imports ESRI.ArcGIS.Geometry
Imports ESRI.ArcGIS.esriSystem
 
<ComClass(Tool1.ClassId, Tool1.InterfaceId, Tool1.EventsId), _
 ProgId("MapControlApplication1.Tool1")> _
Public NotInheritable Class Tool1
    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 = "59356423-f656-49b3-9113-4a225a1b5d62"
    Public Const InterfaceId As String = "ef521b4d-9a87-4678-a398-0291e0fea1a0"
    Public Const EventsId As String = "068591ce-3638-4f38-847b-3661cff220a7"
#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"
    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
    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
 
    'Working with the ArcGIS snapping environment
    'http://resources.arcgis.com/en/help/arcobjects-net/conceptualhelp/index.html#/d/0001000001s1000000.htm
 
    'モジュールレベル変数
    Private m_hookHelper As IHookHelper
    Private m_hookHelper2 As IHookHelper2
    Private m_pSnappingEnvironment As ISnappingEnvironment
 
    Private m_pPoint As IPoint
    Private m_pPointSnapper As IPointSnapper
    Private m_pSnappingFeedback As ISnappingFeedback
 
    ' 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()
 
        ' TODO: Define values for the public properties
        ' TODO: Define values for the public properties
        MyBase.m_category = "test"  'localizable text 
        MyBase.m_caption = "test"   'localizable text 
        MyBase.m_message = "test"   'localizable text 
        MyBase.m_toolTip = "test" 'localizable text 
        MyBase.m_name = "test"  'unique id, non-localizable (e.g. "MyCategory_MyTool")
 
        Try
            'TODO: change resource name if necessary
            Dim bitmapResourceName As String = Me.GetType().Name + ".bmp"
            MyBase.m_bitmap = New Bitmap(Me.GetType(), bitmapResourceName)
            MyBase.m_cursor = New System.Windows.Forms.Cursor(Me.GetType(), Me.GetType().Name + ".cur")
        Catch ex As Exception
            System.Diagnostics.Trace.WriteLine(ex.Message, "Invalid Bitmap")
        End Try
    End Sub
 
 
    Public Overrides Sub OnCreate(ByVal hook As Object)
        If (m_hookHelper Is Nothing) Then m_hookHelper = New HookHelperClass
 
        If Not hook Is Nothing Then
            m_hookHelper.Hook = hook
            m_hookHelper2 = CType(m_hookHelper, IHookHelper2)
        End If
 
        'TODO: Add other initialization code
    End Sub
 
    Public Overrides Sub OnClick()
        'スナップ環境の初期化
        Dim pExtensionManager As IExtensionManager = m_hookHelper2.ExtensionManager
        If Not pExtensionManager Is Nothing Then
            Dim pUID As UID = New UIDClass()
            pUID.Value = "{E07B4C52-C894-4558-B8D4-D4050018D1DA}" 'Snapping extension.
            m_pSnappingEnvironment = TryCast(pExtensionManager.FindExtension(pUID), ISnappingEnvironment)
            m_pSnappingEnvironment.Enabled = True
 
            'スナップ タイプの設定
            m_pSnappingEnvironment.SnappingType = DirectCast(esriSnappingType.esriSnappingTypeEdge + esriSnappingType.esriSnappingTypeEndpoint, esriSnappingType)
 
            'スナップ許容値
            m_pSnappingEnvironment.Tolerance = 10
        End If
 
        'スナップ フィードバックの初期化
        m_pPointSnapper = m_pSnappingEnvironment.PointSnapper
        m_pSnappingFeedback = New SnappingFeedbackClass()
        m_pSnappingFeedback.Initialize(m_hookHelper.Hook, m_pSnappingEnvironment, True)
 
    End Sub
 
    Public Overrides Sub OnMouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)
        'クリック座標の表示
        MessageBox.Show("X:" + m_pPoint.X.ToString() + ", Y:" + m_pPoint.Y.ToString())
    End Sub
 
    Public Overrides Sub OnMouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Integer, ByVal Y As Integer)
        'マップ座標の取得
        m_pPoint = m_hookHelper.ActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)
 
        'スナップのテスト
        Dim snapResult As ISnappingResult = m_pPointSnapper.Snap(m_pPoint)
 
        'スナップ フィードバックの更新
        m_pSnappingFeedback.Update(snapResult, 0)
 
        'スナップされた場合、ポイント座標を更新
        If Not snapResult Is Nothing Then
            m_pPoint = snapResult.Location
        End If
    End Sub
 
    Public Overrides Sub Refresh(hDC As Integer)
        'スナップの更新
        If Not m_pSnappingFeedback Is Nothing Then
            m_pSnappingFeedback.Refresh(hDC)
        End If
 
    End Sub
 
End Class