工具条

开发平台：
Visual Basic

clsZoomOut.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 = "clsZoomOut"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private m_pBitmap As IPictureDisp
Private m_pCursor As IPictureDisp
Private m_pCursorMove As IPictureDisp
Private m_pPoint As esriGeometry.IPoint
Private m_pFeedback As esriDisplay.INewEnvelopeFeedback
Private m_bInUse As Boolean
Private m_pMap As IMap
Implements esriSystemUI.ICommand
Implements esriSystemUI.ITool
Private Sub Class_Initialize()
  '从工程资源文件中加载资源
  Set m_pCursor = LoadResPicture("ZoomOut", vbResCursor)
  Set m_pCursorMove = LoadResPicture("ZoomOutMove", vbResCursor)
  
End Sub
Private Sub Class_Terminate()
  Set m_pBitmap = Nothing
  Set m_pCursor = Nothing
  Set m_pCursorMove = Nothing
End Sub
Private Property Get ICommand_Enabled() As Boolean
  ICommand_Enabled = True
End Property
 
Private Property Get ICommand_Checked() As Boolean
  ICommand_Checked = False
End Property
 
Private Property Get ICommand_Name() As String
  ICommand_Name = "DG_ZoomOut"
End Property
Private Property Get ICommand_Caption() As String
  ICommand_Caption = "缩小"
End Property
 
Private Property Get ICommand_Tooltip() As String
  ICommand_Tooltip = "放大"
End Property
 
Private Property Get ICommand_Message() As String
  ICommand_Message = "拉框或点击进行缩放"
End Property
 
Private Property Get ICommand_HelpFile() As String
  
  ' 在这里可以添加其它的重写代码
  
End Property
 
Private Property Get ICommand_HelpContextID() As Long
  ' 在这里可以添加其它的重写代码
End Property
 
Private Property Get ICommand_Bitmap() As esriSystem.OLE_HANDLE
  ICommand_Bitmap = m_pBitmap
End Property
 
Private Property Get ICommand_Category() As String
  ICommand_Category = "例子/缩小"
End Property
 
Private Sub ICommand_OnCreate(ByVal hook As Object)
   Set m_pMap = hook.map
  
End Sub
 
Private Sub ICommand_OnClick()
  
  ' 在这里可以添加其它的重写代码
End Sub
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
 
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
 
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
 
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
    
  Dim pEnvelope As esriGeometry.IEnvelope
  Dim pFeedEnvelope As esriGeometry.IEnvelope
  Dim newWidth As Double
  Dim newHeight As Double
  
  '得到Map
  Dim pActiveView As esriCarto.IActiveView
  Set pActiveView = m_pMap
  If (m_pFeedback Is Nothing) Then
    '如果没有拖动，就直接缩放
    Set pEnvelope = pActiveView.Extent
    pEnvelope.Expand 1.5, 1.5, True
    pEnvelope.CenterAt m_pPoint
  Else
    '停止拉框
    Set pFeedEnvelope = m_pFeedback.Stop
    '如果长、宽为0则退出
    If (pFeedEnvelope.Width = 0) Or (pFeedEnvelope.Height = 0) Then
      Set m_pFeedback = Nothing
      m_bInUse = False
      Exit Sub
    End If
    
    newWidth = pActiveView.Extent.Width * (pActiveView.Extent.Width / pFeedEnvelope.Width)
    newHeight = pActiveView.Extent.Height * (pActiveView.Extent.Height / pFeedEnvelope.Height)
      
    '计算新的Envelope
    Set pEnvelope = New Envelope
    pEnvelope.PutCoords pActiveView.Extent.XMin - ((pFeedEnvelope.XMin - pActiveView.Extent.XMin) * (pActiveView.Extent.Width / pFeedEnvelope.Width)), _
                   pActiveView.Extent.YMin - ((pFeedEnvelope.YMin - pActiveView.Extent.YMin) * (pActiveView.Extent.Height / pFeedEnvelope.Height)), _
                  (pActiveView.Extent.XMin - ((pFeedEnvelope.XMin - pActiveView.Extent.XMin) * (pActiveView.Extent.Width / pFeedEnvelope.Width))) + newWidth, _
                  (pActiveView.Extent.YMin - ((pFeedEnvelope.YMin - pActiveView.Extent.YMin) * (pActiveView.Extent.Height / pFeedEnvelope.Height))) + newHeight
  End If
  
  '设置Extent
  pActiveView.Extent = pEnvelope
  '刷新
  pActiveView.Refresh
  Set m_pFeedback = Nothing
  m_bInUse = False
End Sub
 
Private Sub ITool_OnDblClick()
  ' 在这里可以添加其它的重写代码
End Sub
 
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
 
Private Sub ITool_OnKeyUp(ByVal KeyCode As Long, ByVal shift As Long)
  ' 在这里可以添加其它的重写代码
End Sub
 
Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean
  ' 在这里可以添加其它的重写代码
End Function
 
Private Sub ITool_Refresh(ByVal hdc As esriSystem.OLE_HANDLE)
  '' 在这里可以添加其它的重写代码
End Sub
 
Private Function ITool_Deactivate() As Boolean
  ITool_Deactivate = True
End Function

						