IRotateTracker の利用

Option Explicit
 
Private pRTracker As IRotateTracker
 
'
'Cancel any tracking:
'
Private Function UIToolControl1_Deactivate() As Boolean
 
    If Not pRTracker Is Nothing Then
        Set pRTracker = Nothing
    End If
    UIToolControl1_Deactivate = True
     
End Function
 
Private Sub UIToolControl1_Refresh(ByVal hDC As Long)
If Not pRTracker Is Nothing Then
    pRTracker.Refresh
End If
End Sub
 
'
'Create a new rotate tracker when selected:
'
Private Sub UIToolControl1_Select()
    'Create new Rotate Tracker:
    Set pRTracker = New RotateTracker
End Sub
 
'
'
'Define the angle:
'
Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)
     
    'Rotate angle graphic with right mouse click:
    If (button = 1) Then
     
        Dim pMxDoc As IMxDocument
        Dim pDisplay As IScreenDisplay
        Set pMxDoc = Application.Document
        Set pDisplay = pMxDoc.ActiveView.ScreenDisplay
         
        Dim pGraphicsContainer As IGraphicsContainer
        Set pGraphicsContainer = pMxDoc.ActiveView.GraphicsContainer
        pGraphicsContainer.Reset
         
        Dim pGraphicContainerSelect As IGraphicsContainerSelect
        Set pGraphicContainerSelect = pMxDoc.ActiveView.GraphicsContainer
         
        'Find the existing angle graphic:
        Dim pElement As IElement
        Set pElement = pGraphicsContainer.Next ' pGraphicContainerSelect.SelectedElement(0) '
        Dim pElement2 As IElement
        Set pElement2 = pGraphicsContainer.Next
         
        If (Not pElement Is Nothing) Then
         
            'Create rotate tracker:
            Set pRTracker.Display = pDisplay
         
            'Assign origin of rotation:
            Dim pGeo As IGeometry
            Dim pGeo2 As IGeometry
             
            Dim pStartPt As IPoint
             
            Set pGeo = pElement.Geometry
            Set pGeo2 = pElement2.Geometry
            Set pStartPt = pMxDoc.ActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y) 'pGeo.FromPoint '
             
            pRTracker.Origin = pMxDoc.ActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y) 'pStartPt '
             
'            Dim pGeometryCollection As IGeometryCollection
'            Set pGeometryCollection = New Polygon
'            pGeometryCollection.AddGeometry pGeo
             
            'Assign geometry to be rotated:
            pRTracker.ClearGeometry
            pRTracker.AddGeometry pGeo
            pRTracker.AddGeometry pGeo2
            pRTracker.AddPoint pStartPt, New SimpleMarkerSymbol
             
            'Start rotation process:
            If Not pRTracker Is Nothing Then
                pRTracker.OnMouseDown
            End If
         
        End If
 
    End If
     
End Sub
'
'Move the rotation tracker:
'
Private Sub UIToolControl1_MouseMove(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)
 
    If (button = 1) Then
     
        If Not pRTracker Is Nothing Then
         
            Dim pMxDoc As IMxDocument
            Dim pDisplay As IScreenDisplay
             
            Set pMxDoc = Application.Document
            Set pDisplay = pMxDoc.ActiveView.ScreenDisplay
             
            Dim pPoint As IPoint
            Set pPoint = pDisplay.DisplayTransformation.ToMapPoint(x, y)
            pRTracker.OnMouseMove pPoint
             
        End If
     
    End If
     
End Sub
 
'
'Update the angle graphic:
'
Private Sub UIToolControl1_MouseUp(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)
 
    'Re-display graphic if being rotated:
    If (button = 1) Then
     
        If (Not pRTracker Is Nothing) Then
         
            If pRTracker.OnMouseUp = True Then
                  
                'This just uses the ITransform2d to rotate the graphic (see earlier code):
'                Call mod_Angles.Update_Angle_Graphic(pRTracker.Angle)
                 
            End If
         
        End If
   
    End If
 
End Sub