放大缩小的代码

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 IActiveView
    Set pActiveView = GetMap()
    Set m_pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
    m_bInUse = True
    SetCapture m_pHook.hwnd
    Exit Sub
ErrorHandler:
    MsgBox Err.Description, vbCritical, "地图缩小"
End Sub

Private Sub ITool_OnMouseMove(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)
    On Error Resume Next
    If (Not m_bInUse) Then Exit Sub
    Dim pActiveView As 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
End Sub

Private Sub ITool_OnMouseUp(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)
        On Error Resume Next
    If (Not m_bInUse) Then Exit Sub
    If GetCapture = m_pHook.hwnd Then
        ReleaseCapture
    End If
    Dim pEnv As IEnvelope
    Dim newWidth As Double
    Dim newheight As Double
    Dim pActiveView As IActiveView
    Dim pExtentEnv As IEnvelope    Set pActiveView = GetMap()
    If (m_pFeedback Is Nothing) Then
        Set pEnv = m_pFeedback.Stop
        Set pExtentEnv = New Envelope
     If ((pEnv.Width > 0) And (pEnv.Height > 0)) Then
        newWidth = pActiveView.Extent.Width * (pActiveView.Extent.Width / pEnv.Width)
        newheight = pActiveView.Extent.Height * (pActiveView.Extent.Height / pEnv.Height)
        pExtentEnv.xMin = pActiveView.Extent.xMin - ((pEnv.xMin - pActiveView.Extent.xMin) * (pActiveView.Extent.Width / pEnv.Width))
        pExtentEnv.yMin = pActiveView.Extent.yMin - ((pEnv.yMin - pActiveView.Extent.yMin) * (pActiveView.Extent.Height / pEnv.Height))
        pExtentEnv.Width = newWidth
        pExtentEnv.Height = newheight
     End If
    Else
    Set pExtentEnv = pActiveView.Extent
    pExtentEnv.Expand 2#, 2#, True
    pExtentEnv.CenterAt pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  End If
  If (Not pActiveView.FullExtent Is Nothing) Then
    If (Not pActiveView.FullExtent.IsEmpty And Not pExtentEnv.IsEmpty) Then
      If ((pExtentEnv.Width > pActiveView.FullExtent.Width) Or _
        (pExtentEnv.Height > pActiveView.FullExtent.Height)) Then _
          Set pExtentEnv = pActiveView.FullExtent
    End If
  End If
 pActiveView.Extent = pExtentEnv
  pActiveView.Refresh
  'reset rubberband and mousedown state
  Set m_pFeedback = Nothing
  m_bInUse = False
  Exit Sub
End Sub
 
Private Sub ITool_OnDblClick()
    On Error GoTo ErrorHandler
    ' TODO: Add your implementation here
    Exit Sub
ErrorHandler:
    MsgBox Err.Description, vbCritical, "地图缩小"
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:
    MsgBox Err.Description, vbCritical, "地图缩小"
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:
    MsgBox Err.Description, vbCritical, "地图缩小"
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:
    MsgBox Err.Description, vbCritical, "地图缩小"
End Function
 
Private Sub ITool_Refresh(ByVal hdc As esricore.OLE_HANDLE)
    On Error GoTo ErrorHandler
    ' TODO: Add your implementation here
    Exit Sub
ErrorHandler:
    MsgBox Err.Description, vbCritical, "地图缩小"
End Sub
 
Private Function ITool_Deactivate() As Boolean
    On Error GoTo ErrorHandler
    ITool_Deactivate = True
    Exit Function
ErrorHandler:
    MsgBox Err.Description, vbCritical, "地图缩小"   
End Function