clszoomin.cls

ao开发指南的东西 源码 希望大家好好学习ao

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 1  'Persistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ZoomIn"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'Windows API functions to capture mouse and keyboard
'input to a window when the mouse is outside the window
Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long

Private m_pHook As New hook
Private m_pPoint As esriCore.IPoint
Private m_pFeedback As esriCore.INewEnvelopeFeedback
Private m_bInUse As Boolean
Private m_pBitmap As IPictureDisp
Private m_pCursor As IPictureDisp
Private m_pCursorMove As IPictureDisp

Implements ICommand
Implements ITool
'Constant used by the Error handler function - DO NOT REMOVE
Const c_ModuleFileName = "clsZoomIn.cls"

Private Function GetMap() As esriCore.IMap
  On Error GoTo ErrorHandler

  Set GetMap = m_pHook.FocusMap


  Exit Function
ErrorHandler:
  HandleError False, "GetMap " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Function

Private Sub Class_Initialize()
  On Error GoTo ErrorHandler

  Set m_pBitmap = LoadResPicture("ZoomIn", vbResBitmap)
  Set m_pCursor = LoadResPicture("ZoomIn", vbResCursor)
  Set m_pCursorMove = LoadResPicture("ZoomInMove", vbResCursor)

  Exit Sub
ErrorHandler:
  HandleError True, "Class_Initialize " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub

Private Sub Class_Terminate()
  On Error GoTo ErrorHandler

  Set m_pHook = Nothing
  Set m_pBitmap = Nothing
  Set m_pCursor = Nothing
  Set m_pCursorMove = Nothing
  
  Exit Sub
ErrorHandler:
  HandleError True, "Class_Terminate " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub

Private Property Get ICommand_Enabled() As Boolean
  On Error GoTo ErrorHandler

  If (GetMap Is Nothing) Then Exit Property
  ICommand_Enabled = True

  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Enabled " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Checked() As Boolean
  On Error GoTo ErrorHandler

  ICommand_Checked = False


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Checked " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Name() As String
  On Error GoTo ErrorHandler

  ICommand_Name = "Sample_Pan/Zoom_Zoom In"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Name " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property

Private Property Get ICommand_Caption() As String
  On Error GoTo ErrorHandler

  ICommand_Caption = "Zoom In"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Caption " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Tooltip() As String
  On Error GoTo ErrorHandler

  ICommand_Tooltip = "Zoom In"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Tooltip " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Message() As String
  On Error GoTo ErrorHandler

  ICommand_Message = "Zooms the Display In By Rectangle Or Single Click"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Message " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_HelpFile() As String
  On Error GoTo ErrorHandler

  ' TODO: Add your implementation here


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_HelpFile " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_HelpContextID() As Long
  On Error GoTo ErrorHandler

  ' TODO: Add your implementation here


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_HelpContextID " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Bitmap() As esriCore.OLE_HANDLE
  On Error GoTo ErrorHandler

  ICommand_Bitmap = m_pBitmap


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Bitmap " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Property Get ICommand_Category() As String
  On Error GoTo ErrorHandler

  ICommand_Category = "Sample_Pan/Zoom"


  Exit Property
ErrorHandler:
  HandleError True, "ICommand_Category " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Sub ICommand_OnCreate(ByVal hook As Object)
  On Error GoTo ErrorHandler

  m_pHook.hook = hook


  Exit Sub
ErrorHandler:
  HandleError True, "ICommand_OnCreate " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub
 
Private Sub ICommand_OnClick()
  On Error GoTo ErrorHandler

  


  Exit Sub
ErrorHandler:
  HandleError True, "ICommand_OnClick " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub

Private Property Get ITool_Cursor() As esriCore.OLE_HANDLE
  On Error GoTo ErrorHandler

  If (m_bInUse) Then
    ITool_Cursor = m_pCursorMove
  Else
    ITool_Cursor = m_pCursor
  End If


  Exit Property
ErrorHandler:
  HandleError True, "ITool_Cursor " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Property
 
Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
  On Error GoTo ErrorHandler

  If TypeOf m_pHook.ActiveView Is IPageLayout Then
    Dim pPoint As IPoint
    Set pPoint = m_pHook.ActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)
    Dim pMap As IMap
    Set pMap = m_pHook.ActiveView.HitTestMap(pPoint)
    If pMap Is Nothing Then Exit Sub
    If Not pMap Is m_pHook.FocusMap Then
      Set m_pHook.ActiveView.FocusMap = pMap
      m_pHook.ActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing
    End If
  End If

  Dim pActiveView As esriCore.IActiveView
  Set pActiveView = GetMap()
  Set m_pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)

  m_bInUse = True
  SetCapture m_pHook.hWnd
  
  Exit Sub
ErrorHandler:
  HandleError True, "ITool_OnMouseDown " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub
 
Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
  On Error GoTo ErrorHandler

  If (Not m_bInUse) Then Exit Sub
  
  Dim pActiveView As esriCore.IActiveView
  Set pActiveView = GetMap()
  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)


  Exit Sub
ErrorHandler:
  HandleError True, "ITool_OnMouseMove " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub
 
Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
  On Error GoTo ErrorHandler

  If (Not m_bInUse) Then Exit Sub
    
  If GetCapture = m_pHook.hWnd Then
    ReleaseCapture
  End If
    
  Dim pEnv As esriCore.IEnvelope
  Dim pActiveView As esriCore.IActiveView
  Set pActiveView = GetMap()
  If (m_pFeedback Is Nothing) Then
    Set pEnv = pActiveView.Extent
    pEnv.Expand 0.5, 0.5, True
    pEnv.CenterAt m_pPoint
  Else
    Set pEnv = m_pFeedback.Stop
    If (pEnv.Width = 0) Or (pEnv.Height = 0) Then
      Set m_pFeedback = Nothing
      m_bInUse = False
      Exit Sub
    End If
  End If
  
  pActiveView.Extent = pEnv
  pActiveView.Refresh
  Set m_pFeedback = Nothing
  m_bInUse = False


  Exit Sub
ErrorHandler:
  HandleError True, "ITool_OnMouseUp " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub
 
Private Sub ITool_OnDblClick()
  On Error GoTo ErrorHandler

  ' TODO: Add your implementation here


  Exit Sub
ErrorHandler:
  HandleError True, "ITool_OnDblClick " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub
 
Private Sub ITool_OnKeyDown(ByVal keyCode As Long, ByVal Shift As Long)
  On Error GoTo ErrorHandler

  If m_bInUse = True Then
    If keyCode = 27 Then  'ESC key
      ReleaseCapture
      Set m_pFeedback = Nothing
      m_bInUse = False
      m_pHook.ActiveView.PartialRefresh esriViewForeground, Nothing, Nothing
    End If
  End If

  Exit Sub
ErrorHandler:
  HandleError True, "ITool_OnKeyDown " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub
 
Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long)
  On Error GoTo ErrorHandler


  ' TODO: Add your implementation here


  Exit Sub
ErrorHandler:
  HandleError True, "ITool_OnKeyUp " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub
 
Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean
  On Error GoTo ErrorHandler

  ' TODO: Add your implementation here


  Exit Function
ErrorHandler:
  HandleError True, "ITool_OnContextMenu " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Function
 
Private Sub ITool_Refresh(ByVal hDC As esriCore.OLE_HANDLE)
  On Error GoTo ErrorHandler

  ' TODO: Add your implementation here


  Exit Sub
ErrorHandler:
  HandleError True, "ITool_Refresh " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Sub
 
Private Function ITool_Deactivate() As Boolean
  On Error GoTo ErrorHandler

  ITool_Deactivate = True


  Exit Function
ErrorHandler:
  HandleError True, "ITool_Deactivate " & c_ModuleFileName & " " & GetErrorLineNumberString(Erl), Err.Number, Err.Source, Err.Description, 1
End Function