| |
Option Explicit
Private Function UIToolControl1_Deactivate() As Boolean
UIToolControl1_Deactivate = True
End Function
Private Sub UIToolControl1_MouseDown _
(ByVal button As Long, ByVal shift As Long, _
ByVal x As Long, ByVal y As Long)
'
' get the measure where the user clicks
'
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
If pMxDoc.SelectedItem Is Nothing Then
MsgBox "choose a layer in the TOC first"
Exit Sub
End If
If Not TypeOf pMxDoc.SelectedItem Is IFeatureLayer Then
MsgBox "choose a layer in the TOC first"
Exit Sub
End If
Dim pFLayer As IFeatureLayer
Set pFLayer = pMxDoc.SelectedItem
Dim pAV As IActiveView
Set pAV = pMxDoc.FocusMap
Dim pPoint As IPoint
Set pPoint = pAV.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
Dim pEnv As IEnvelope
Set pEnv = pPoint.Envelope
pEnv.Expand pMxDoc.SearchTolerance, pMxDoc.SearchTolerance, False
Dim pSF As ISpatialFilter
Set pSF = New SpatialFilter
Set pSF.Geometry = pEnv
pSF.SpatialRel = esriSpatialRelEnvelopeIntersects
pSF.GeometryField = pFLayer.FeatureClass.ShapeFieldName
Set pSF.OutputSpatialReference(pFLayer.FeatureClass.ShapeFieldName) = _
pMxDoc.FocusMap.SpatialReference
Dim pFCur As IFeatureCursor
Set pFCur = pFLayer.FeatureClass.Search(pSF, False)
Dim pProxOp As IProximityOperator
Set pProxOp = pPoint
Dim pFeat As IFeature, pClosestFeat As IFeature
Dim dDist As Double, dClosestDist As Double
Set pFeat = pFCur.NextFeature
Do Until pFeat Is Nothing
dDist = pProxOp.ReturnDistance(pFeat.Shape)
If pClosestFeat Is Nothing Then
Set pClosestFeat = pFeat
dClosestDist = dDist
Else
If dDist < dClosestDist Then
Set pClosestFeat = pFeat
dClosestDist = dDist
End If
End If
Set pFeat = pFCur.NextFeature
Loop
If pClosestFeat Is Nothing Then Exit Sub
If Not TypeOf pClosestFeat.Shape Is IMSegmentation2 Then
MsgBox "no measures on feature"
Exit Sub
End If
Dim pPolyline As IPolyline
Set pPolyline = pClosestFeat.ShapeCopy
Dim pOutPoint As IPoint
Set pOutPoint = New Point
Dim dAlong As Double, dFrom As Double, bRight As Boolean
pPolyline.QueryPointAndDistance esriNoExtension, _
pPoint, False, _
pOutPoint, dAlong, _
dFrom, bRight
Dim pMSeg As IMSegmentation2, vMeasures As Variant
Set pMSeg = pPolyline
vMeasures = pMSeg.GetMsAtDistance(dAlong, False)
Application.StatusBar.Message(0) = vMeasures(0)
End Sub
|