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
記事
