工具条

开发平台：
Visual Basic

clsPan.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 = "clsPan"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private m_pPoint As esriGeometry.IPoint
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
Implements esriSystemUI.ICommand
Implements esriSystemUI.ITool
Private Sub Class_Initialize()
  '从项目资源文件中加载资源
  Set m_pBitmap = LoadResPicture("Pan", vbResBitmap)
  Set m_pCursorMove = LoadResPicture("PanMove", vbResCursor)
  Set m_pCursor = LoadResPicture("Pan", 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_Pan"
End Property
Private Property Get ICommand_Caption() As String
  ICommand_Caption = "Pan"
End Property
 
Private Property Get ICommand_Tooltip() As String
  ICommand_Tooltip = "漫游"
End Property
 
Private Property Get ICommand_Message() As String
  ICommand_Message = "Pans The Display By Grabbing"
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 = "Sample_Pan/Zoom"
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
  If (pActiveView Is Nothing) Then Exit Sub
  '开始漫游
  Set m_pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)
  pActiveView.ScreenDisplay.PanStart m_pPoint
  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
  
  Dim pActiveView As esriCarto.IActiveView
  Set pActiveView = m_pMap
  '移动地图
  pActiveView.ScreenDisplay.PanMoveTo 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 pActiveView As esriCarto.IActiveView
  Set pActiveView = m_pMap
  '停止漫游
  Dim pEnvelope As esriGeometry.IEnvelope
  Set pEnvelope = pActiveView.ScreenDisplay.PanStop
  
  pActiveView.Extent = pEnvelope
  pActiveView.Refresh
  m_bInUse = False
End Sub
 
Private Sub ITool_OnDblClick()
  ' 在这里可以添加其它的重写代码
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 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

						