Option Explicit '实现Icommand接口 Implements ICommand Dim m_pPicture as Picture Dim m_pApplication As IApplication
Private Sub Class_Initialize() '调入.RES文件中ID为101的BitMap作为该按钮的显示图片 Set m_pPicture = LoadResPicture(101, vbResBitmap) End Sub
Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE ICommand_Bitmap = m_pPicture End Property
Private Property Get ICommand_Caption() As String ICommand_Caption = "Create Button" End Property
Private Property Get ICommand_Category() As String ICommand_Category = " Create Button " 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 End Property
Private Property Get ICommand_Name() As String ICommand_Name = " CreateButton " End Property
Private Sub ICommand_OnClick() '加入按下按钮时实现的功能代码。在这里, '按钮按下时显示ArcMap的Document的Tittle Dim pDocument As IDocument Set pDocument = m_pApplication.Document MsgBox pDocument.Title End Sub
Private Sub ICommand_OnCreate(ByVal hook As Object) '获取ArcMap的Application实例 Set m_pApplication = hook End Sub
Private Property Get ICommand_Tooltip() As String ICommand_Tooltip = " Create Button " End Property
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 pMxApplication As IMxApplication Set pMxApplication = m_pApp Set pPoint=pMxApplication.Display.DisplayTransformation.ToMapPoint(X, Y) m_pApplication.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_pApplication.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_pApplication.StatusBar.Message(0) = "ITool_OnMouseUp" End Sub
Private Sub ITool_Refresh(ByVal hDC As esriCore.OLE_HANDLE) End Sub |