clstool.cls

这是一个非常全的VB+AO二次开发实例集

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clstool"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
'实现Icommand和Itool接口
Implements ICommand
Implements ITool
Dim m_pApp As IApplication
Dim m_pBitmap As IPictureDisp
Dim m_pCursor As IPictureDisp

Private Sub Class_Initialize()
   Set m_pBitmap = LoadResPicture(101, 0)
   '从.RES文件中调入ID为102的图片作为按下Tool后的MouseCursor
   Set m_pCursor = LoadResPicture(102, 2)
End Sub
 
Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE
   ICommand_Bitmap = m_pBitmap
End Property
 
Private Property Get ICommand_Caption() As String
   ICommand_Caption = "MyTool"
End Property
 
Private Property Get ICommand_Category() As String
   ICommand_Category = "MyCustomTools"
End Property
 
Private Property Get ICommand_Checked() As Boolean
End Property
 
Private Property Get ICommand_Enabled() As Boolean
   ICommand_Enabled = True
End Property
 
Private Property Get ICommand_HelpContextID() As Long
End Property
 
Private Property Get ICommand_HelpFile() As String
End Property
 
Private Property Get ICommand_Message() As String
   ICommand_Message = "This is my custom tool"
End Property
 
Private Property Get ICommand_Name() As String
   ICommand_Name = "MyCustomTool_MyTool"
End Property
 
Private Sub ICommand_OnClick()
   '加入按下按钮时实现的功能代码
   MsgBox "Clicked on my command"
End Sub
 
Private Sub ICommand_OnCreate(ByVal hook As Object)
   '获取ArcMAP的Application实例
   Set m_pApp = hook
End Sub
 
Private Property Get ICommand_Tooltip() As String
   ICommand_Tooltip = "MyTool"
End Property
 
Private Property Get ITool_Cursor() As esriCore.OLE_HANDLE
   ITool_Cursor = m_pCursor
End Property
 
Private Function ITool_Deactivate() As Boolean
   '如果ITool_Deactivate设为False，则Tool不可用。
   ITool_Deactivate = True
End Function
 
Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean
   '在这里可以加入用户代码，点击Mouse右键时显示一个定制的context menu
End Function
 
Private Sub ITool_OnDblClick()
   '在这里加入Mouse双击时的功能代码
End Sub
 
Private Sub ITool_OnKeyDown(ByVal keyCode As Long, ByVal Shift As Long)
End Sub
 
Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long)
End Sub
 
Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
   '加入Mouse单击时的功能代码。
   If Button = 1 Then
      Dim pPoint As IPoint
      Dim pMxApp As IMxApplication
      Set pMxApp = m_pApp
      Set pPoint = pMxApp.Display.DisplayTransformation.ToMapPoint(X, Y)
      m_pApp.StatusBar.Message(0) = Str(pPoint.X) & "," & Str(pPoint.Y)
 End If
End Sub
 
Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
   '加入Mouse移动时的功能代码
   m_pApp.StatusBar.Message(0) = "ITool_OnMouseMove"
End Sub
 
Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
   '加入释放Mouse时的功能代码
   m_pApp.StatusBar.Message(0) = "ITool_OnMouseUp"
End Sub
 
Private Sub ITool_Refresh(ByVal hDC As esriCore.OLE_HANDLE)
End Sub