工具条

开发平台：
Visual Basic

clsZoomIn.cls：源码内容
							VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsZoomIn"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Implements esriSystemUI.ICommand   '继承ICommand接口
Implements esriSystemUI.ITool      '继承ITool接口
'定义类变量成员
Private m_pPoint As esriGeometry.IPoint
Private m_pFeedback As esriDisplay.INewEnvelopeFeedback
Private m_bInUse As Boolean
Private m_pBitmap As IPictureDisp
Private m_pCursor As IPictureDisp
Private m_pCursorMove As IPictureDisp
Private m_pMap As IMap
'重写类的Initialize()方法
Private Sub Class_Initialize()
  '从项目的资源文件中加载资源
  Set m_pCursor = LoadResPicture("ZoomIn", vbResCursor)
  Set m_pCursorMove = LoadResPicture("ZoomInMove", vbResCursor)
End Sub
'重写类的Terminate()方法
Private Sub Class_Terminate()
  '释放对象
  Set m_pCursor = Nothing
  Set m_pCursorMove = Nothing
End Sub
'实现ICommand接口的Enabled属性
Private Property Get ICommand_Enabled() As Boolean
  ICommand_Enabled = True
End Property
'实现ICommand接口的Checked属性
Private Property Get ICommand_Checked() As Boolean
  ICommand_Checked = False
End Property
'实现ICommand接口的Name属性
Private Property Get ICommand_Name() As String
  ICommand_Name = "DG_ZoomIn"
End Property
'实现ICommand接口的Caption属性
Private Property Get ICommand_Caption() As String
  ICommand_Caption = "放大"
End Property
'实现ICommand接口的Tooltip属性
Private Property Get ICommand_Tooltip() As String
  ICommand_Tooltip = "拉框放大"
End Property
'实现ICommand接口的Message属性
Private Property Get ICommand_Message() As String
  ICommand_Message = "通过点击或拉框进行放大操作"
End Property
'实现ICommand接口的HelpFile属性
Private Property Get ICommand_HelpFile() As String
  ' 在这里可以添加其它的重写代码
End Property
'实现ICommand接口的HelpContextID属性
Private Property Get ICommand_HelpContextID() As Long
  ' 在这里可以添加其它的重写代码
End Property
'实现ICommand接口的Bitmap属性
Private Property Get ICommand_Bitmap() As esriSystem.OLE_HANDLE
  ICommand_Bitmap = m_pBitmap
End Property
'实现ICommand接口的Category属性
Private Property Get ICommand_Category() As String
  ICommand_Category = "例子/缩放"
End Property
'定义ICommand接口的OnCreate事件
Private Sub ICommand_OnCreate(ByVal hook As Object)
   Set m_pMap = hook.Map
End Sub
'定义ICommand接口的OnClick事件
Private Sub ICommand_OnClick()
 ' 在这里可以添加其它的重写代码
End Sub
'实现ITool接口的Cursor属性
Private Property Get ITool_Cursor() As esriSystem.OLE_HANDLE
  If (m_bInUse) Then
    ITool_Cursor = m_pCursorMove
  Else
    ITool_Cursor = m_pCursor
  End If
End Property
'定义ITool接口的OnMouseDown事件
Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal shift As Long, ByVal X As Long, ByVal Y As Long)
  Dim pActiveView As esriCarto.IActiveView
  Set pActiveView = m_pMap
  Set m_pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)
  m_bInUse = True
  
End Sub
'定义ITool接口的OnMouseMove事件
Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal shift As Long, ByVal X As Long, ByVal Y As Long)
  If (Not m_bInUse) Then Exit Sub
  
  '获得map
  Dim pActiveView As esriCarto.IActiveView
  Set pActiveView = m_pMap
  '开始拉框
  If (m_pFeedback Is Nothing) Then
    Set m_pFeedback = New NewEnvelopeFeedback
    Set m_pFeedback.Display = pActiveView.ScreenDisplay
    m_pFeedback.Start m_pPoint
  End If
  '绘制矩形框
  m_pFeedback.MoveTo pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)
End Sub
'定义ITool接口的OnMouseUp事件
Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal shift As Long, ByVal X As Long, ByVal Y As Long)
  If (Not m_bInUse) Then Exit Sub
    
  '停止拉框
    
  '获得map
  Dim pActiveView As esriCarto.IActiveView
  Set pActiveView = m_pMap
  '如果有Envelope
  Dim pEnvelope As esriGeometry.IEnvelope
  If (m_pFeedback Is Nothing) Then
    '点击缩放
    Set pEnvelope = pActiveView.Extent
    pEnvelope.Expand 0.8, 0.8, True
    pEnvelope.CenterAt m_pPoint
  Else
    '停止拉框
    Set pEnvelope = m_pFeedback.Stop
    '如果长、宽为0则退出
    If (pEnvelope.Width = 0) Or (pEnvelope.Height = 0) Then
      Set m_pFeedback = Nothing
      m_bInUse = False
      Exit Sub
    End If
  End If
  
  '设置新的Extent
  pActiveView.Extent = pEnvelope
  pActiveView.Refresh
  Set m_pFeedback = Nothing
  m_bInUse = False
End Sub
'定义ITool接口的OnDblClick事件
Private Sub ITool_OnDblClick()
  ' 在这里可以添加其它的重写代码
End Sub
'定义ITool接口的OnKeyDown事件
Private Sub ITool_OnKeyDown(ByVal KeyCode As Long, ByVal shift As Long)
  If m_bInUse = True Then
    If KeyCode = 27 Then  'ESC key
      '停止捕获
      Set m_pFeedback = Nothing
      m_bInUse = False
    End If
  End If
End Sub
'定义ITool接口的OnKeyUp事件
Private Sub ITool_OnKeyUp(ByVal KeyCode As Long, ByVal shift As Long)
  ' 在这里可以添加其它的重写代码
  
End Sub
'定义ITool接口的OnContextMenu事件
Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean
  ' 在这里可以添加其它的重写代码
End Function
'实现ITool接口的OnKeyDown方法
Private Sub ITool_Refresh(ByVal hdc As esriSystem.OLE_HANDLE)
  ' 在这里可以添加其它的重写代码
End Sub
'实现ITool接口的Deactivate方法
Private Function ITool_Deactivate() As Boolean
  ITool_Deactivate = True
  
End Function

						