clsmeasure.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 = "Measure"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private m_pHook As New hook
Private m_pBitmap As IPictureDisp
Private m_pCursor As IPictureDisp
Private m_pNewDimFeed As INewDimensionFeedback ' the NewDimensionFeedback
Private m_bInUse As Boolean

Implements ICommand
Implements ITool

' Constant used by the Error handler function - DO NOT REMOVE
Const c_ModuleFileName = "clsMeasure.cls"


Private Sub Class_Initialize()
  On Error GoTo ErrorHandler

  Set m_pBitmap = LoadResPicture("Measure", vbResBitmap)
  Set m_pCursor = LoadResPicture("Measure", 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

  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 = (GetMap.layerCount > 0)


  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_Selection_Measure"


  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 = "Measure"


  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 = "Mesaure Distance"


  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 = "Measure Distance on Map"


  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 esriSystem.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_Selection"


  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 esriSystem.OLE_HANDLE
  On Error GoTo ErrorHandler

  ITool_Cursor = m_pCursor

  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

  Dim pMap As IMap
  If TypeOf m_pHook.ActiveView Is IPageLayout Then
    Dim pPoint As IPoint
    Set pPoint = m_pHook.ActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)
    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 pPnt As IPoint
  Dim pDispFeed As IDisplayFeedback
  Dim pAv As IActiveView
  
  Set pMap = m_pHook.FocusMap
  Set pAv = pMap
  
  ' Get the current mouse location in Map Units
  Set pPnt = pAv.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)
  
  ' Check that the user is not currently using the feedback
  If m_pNewDimFeed Is Nothing Then
       
    ' Create a new Feedback object
    Set m_pNewDimFeed = New NewDimensionFeedback
    ' QI for IDisplayFeedback
    Set pDispFeed = m_pNewDimFeed
      
    ' Set the reference scale and reference scale units if possible
    Dim MapUnits As esriUnits
    MapUnits = pAv.ScreenDisplay.DisplayTransformation.Units
    If MapUnits <> esriUnknownUnits Then
      m_pNewDimFeed.ReferenceScale = pMap.MapScale
      m_pNewDimFeed.ReferenceScaleUnits = MapUnits
    End If
    
    'Set the Feedback's Display
    Set pDispFeed.Display = pAv.ScreenDisplay
  Else
    m_pNewDimFeed.Stop
    Set m_pNewDimFeed = Nothing
    
  End If
  
  m_bInUse = False
  
  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
  
  Dim pMap As IMap
  Dim pAv As IActiveView
  
  Set pMap = m_pHook.FocusMap
  Set pAv = pMap
  
  ' Check if the user is currently using the feedback
  If Not m_pNewDimFeed Is Nothing Then
    Dim pPnt As IPoint
    ' Get the current mouse location in map units
    Set pPnt = pAv.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)

    If Not m_bInUse Then
      ' Start the feedback at the current mouse location
      m_pNewDimFeed.Start pPnt
      m_bInUse = True
    Else
      Dim pDispFeed As IDisplayFeedback
      ' QI for IDisplayFeedback and use this to move the feedback
      Set pDispFeed = m_pNewDimFeed
      pDispFeed.MoveTo pPnt
    End If
  End If
  
  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

  ' TODO - Add code
  
  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

  ' TODO: Add your implementation here


  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 esriSystem.OLE_HANDLE)
  On Error GoTo ErrorHandler

  ' Check if the user is currently using the feedback
  If Not m_pNewDimFeed Is Nothing Then
     Dim pDispFeed As IDisplayFeedback
       Set pDispFeed = m_pNewDimFeed
       pDispFeed.Refresh hDC
  End If

  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

  ' stop doing operation
  Set m_pNewDimFeed = Nothing

  ITool_Deactivate = True

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

Private Function GetMap() As esriCarto.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