Solved! Go to Solution.
Dim objLayer, objRS, objRect, myQuery, myRec, myValue Set objLayer=application.map.layers("My Layer Name") myValue = 357799 Set objRS=objLayer.records If (Not objRS Is Nothing) Then objRS.MoveFirst For i = 0 To objRS.RecordCount - 1 If objRS.Fields("FieldName").Value = myValue Then myRec = i+1 End If objRS.MoveNext Next End If If (myRec > 0) Then 'Zoom to feature Set objRect=objRS.Fields.Shape.Extent Call objRect.ScaleRectangle(0.5) Application.Map.Extent = objRect Application.Map.Refresh Else msgbox "Feature Not Found!" End If Set objRect = Nothing Set objLyr = Nothing Set objRS = Nothing Set pDS = Nothing
Sub SelectAndZoomTo
Dim objLayer, objRS, objRect, myQuery, myRec, myValue
Set objLayer=application.map.layers("My Layer Name")
myValue = "Lookup Value"
Set objRS=objLayer.records
myQuery = "[FieldName]= """ & myValue & """
myRec = objRS.Find(myQuery)
'If feature is found
If (myRec > 0) Then
objRS.movefirst
objRS.move(myRec-1)
Set objRect=objRS.Fields.Shape.Extent
Map.Extent=objRect
'If feture is Not found
Else
msgbox "Feature NOT Found!"
End If
Map.Refresh
End Sub
Dim objLayer, objRS, objRect, myQuery, myRec, myValue Set objLayer=application.map.layers("My Layer Name") myValue = 357799 Set objRS=objLayer.records If (Not objRS Is Nothing) Then objRS.MoveFirst For i = 0 To objRS.RecordCount - 1 If objRS.Fields("FieldName").Value = myValue Then myRec = i+1 End If objRS.MoveNext Next End If If (myRec > 0) Then 'Zoom to feature Set objRect=objRS.Fields.Shape.Extent Call objRect.ScaleRectangle(0.5) Application.Map.Extent = objRect Application.Map.Refresh Else msgbox "Feature Not Found!" End If Set objRect = Nothing Set objLyr = Nothing Set objRS = Nothing Set pDS = Nothing