如何选择对象，多次点选，多次点选去消[代码][原创]

数据可以自己修改，很多兄弟有这个问题，偶尔看到这个例子，所以发到这里，大家讨论！

Option Explicit

'Change these constants to the name of your shapefile,
'and the name of the field in that shapefile that
'contains unique ID values.  The shapefile must
'reside in the same directory as this project.
Private Const STREET_LAYERNAME = "smallstr"
Private Const STREETID_FLDNAME = "FeatureID"

'Module-level variables
Private m_mlyrStreets As New MapObjects2.MapLayer
Private m_recsStreets As MapObjects2.Recordset
Private m_recsSelStreets As MapObjects2.Recordset
Private m_symSelStreets As New MapObjects2.Symbol
Private m_tol As Double

'Module-level collections
Private m_collSelPolys As New VBA.Collection
Private m_collSelIds As New VBA.Collection

'Module constants
Private Const SELTYPE_REMOVE = 0
Private Const SELTYPE_ADD = 1
'

Private Sub Form_Load()

'Add the streets line shapefile
Dim dc As New MapObjects2.DataConnection
dc.Database = App.Path
If Not dc.Connect Then
  MsgBox "Cannot connect to " & App.Path
  End
End If
Set m_mlyrStreets.GeoDataset = dc.FindGeoDataset(STREET_LAYERNAME)
m_mlyrStreets.Symbol.Color = moBlue
Map1.Layers.Add m_mlyrStreets
Set m_recsStreets = m_mlyrStreets.Records

'Setup selection symbology
m_symSelStreets.SymbolType = moLineSymbol
m_symSelStreets.Style = moSolidLine
m_symSelStreets.Color = RGB(200, 200, 0) 'dark yellow

End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As Stdole.OLE_HANDLE)

'Draw the selected streets
If Not m_recsSelStreets Is Nothing Then
  Map1.DrawShape m_recsSelStreets, m_symSelStreets
End If

End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

    Dim pt As MapObjects2.Point
    Dim poly As MapObjects2.Polygon
    Dim selPoly As New MapObjects2.Polygon
    Dim lnTemp As MapObjects2.Line
    Dim ptTemp As MapObjects2.Point
    Dim i As Long
    Dim recsSelTemp As MapObjects2.Recordset
    Dim strTemp As String
    Dim idxTemp As Long

  'Create a 3 pixel length in map units
  m_tol = Map1.ToMapDistance(3 * Screen.TwipsPerPixelX)
  'Capture the mouse click in map units
  Set pt = Map1.ToMapPoint(x, y)
  'Create a small triangle buffer around the clicked point
  Set poly = MakePolyFromPoint(pt, m_tol)
  

Select Case True

  Case optNew   'clear the old selection, make a new selection
    
    'Clear the global selection recordset variables for reuse.
    Set m_recsSelStreets = Nothing
    Set m_collSelPolys = New VBA.Collection
    Set m_collSelIds = New VBA.Collection

    'Select the streets clicked on
    Set recsSelTemp = m_mlyrStreets.SearchShape(poly, moLineCross, "")
    
    'Only continue if only one street was selected.
    If recsSelTemp.Count = 1 Then
      Set lnTemp = recsSelTemp.Fields("Shape").Value
      m_collSelPolys.Add poly
      m_collSelIds.Add recsSelTemp.Fields(STREETID_FLDNAME).Value
      Call SelectStreets
     Else
      Set m_recsSelStreets = Nothing
      Map1.Refresh
    End If
        
  Case optAddTo  'add new selection to the current selection list
    
    'Select the streets clicked on
    Set recsSelTemp = m_mlyrStreets.SearchShape(poly, moLineCross, "")
    
    'Only continue if only one street was selected.
    If recsSelTemp.Count = 1 Then
      m_collSelPolys.Add poly
      m_collSelIds.Add recsSelTemp.Fields(STREETID_FLDNAME).Value
      Call SelectStreets
    End If

  Case optRemoveFrom  'remove new selection from the current selection list
    
    Set selPoly = New MapObjects2.Polygon
    
    'Select the street
    Set recsSelTemp = m_mlyrStreets.SearchShape(poly, moLineCross, "")
    
    'Only continue if only one street was selected.
    If recsSelTemp.Count = 1 Then
      'Get the ID value of the selected street
      strTemp = recsSelTemp.Fields(STREETID_FLDNAME).Value
      'Find that ID value in the current ID selection list
      idxTemp = FindStringInCollection(strTemp)
      'If the ID is found, then remove that street from the selection list
      If idxTemp > 0 Then
        m_collSelPolys.Remove idxTemp
        m_collSelIds.Remove idxTemp
      End If
      'Select the streets based on the current selection list
      Call SelectStreets
    End If

End Select
    
End Sub


Private Function MakePolyFromPoint(pt As MapObjects2.Point, ByVal m_tol As Double) As MapObjects2.Polygon

'Make a triangle 3 screen pixels in radius around the input point.
  
  Dim poly As New MapObjects2.Polygon
  Dim ptArray(2) As MapObjects2.Point
  Dim pts As New MapObjects2.Points
  
  Set ptArray(0) = New MapObjects2.Point
  Set ptArray(1) = New MapObjects2.Point
  Set ptArray(2) = New MapObjects2.Point
  
  ptArray(0).x = pt.x - m_tol
  ptArray(0).y = pt.y - m_tol
  pts.Add ptArray(0)
  ptArray(1).x = pt.x
  ptArray(1).y = pt.y + m_tol
  pts.Add ptArray(1)
  ptArray(2).x = pt.x + m_tol
  ptArray(2).y = pt.y - m_tol
  pts.Add ptArray(2)
  poly.Parts.Add pts

  Set MakePolyFromPoint = poly
  
End Function

Private Sub UpdateLengthLabel()

'Add the lengths of the selected roads,
'display in a label on the form.

Dim dRunLength As Double
Dim ln As MapObjects2.Line

dRunLength = 0
If Not m_recsSelStreets Is Nothing Then
  If m_recsSelStreets.Count > 0 Then
    m_recsSelStreets.MoveFirst
    Do Until m_recsSelStreets.EOF
      Set ln = m_recsSelStreets.Fields("Shape").Value
      dRunLength = dRunLength + ln.Length
      m_recsSelStreets.MoveNext
    Loop
  End If
End If

dRunLength = Format(dRunLength, "#0.000000000000")
Label2.Caption = "Road length of selected set:  " & dRunLength

End Sub

Private Function SelectStreets()

'Given the current state of the polygon collection,
'make a new multi-part polygon out of the triangular
'rings.  Then select the streets with that multi-part
'polygon, update the length label and redraw the map.

Dim selPoly As New MapObjects2.Polygon
Dim i As Long

'Build a multi-part polygon from the polys in the collection
For i = 1 To m_collSelPolys.Count
  selPoly.Parts.Add m_collSelPolys(i).Parts(0)
Next

'Select the streets using that multi-part polygon
'consisting of triangular rings.
Set m_recsSelStreets = m_mlyrStreets.SearchShape(selPoly, moLineCross, "")

'Update the length label
Call UpdateLengthLabel

'Redraw the map
Map1.Refresh
 
End Function

Private Sub cmdFlipSet_Click()

Dim collFlipPolys As New VBA.Collection
Dim collFlipIds As New VBA.Collection
Dim lnTemp As MapObjects2.Line
Dim ptTemp As MapObjects2.Point
Dim polyTemp As MapObjects2.Polygon
Dim selPoly As MapObjects2.Polygon
Dim strTemp As String
Dim idx As Long

'Create a 3 pixel length in map units
m_tol = Map1.ToMapDistance(3 * Screen.TwipsPerPixelX)

'Cycle through the base layer of streets.
'For each street, check to see if it is not
'selected.  It it is not, then add it to the
'flip set.
m_recsStreets.MoveFirst
Do Until m_recsStreets.EOF
  strTemp = m_recsStreets.Fields(STREETID_FLDNAME).Value
  idx = FindStringInCollection(strTemp)
  If idx = 0 Then
    Set lnTemp = m_recsStreets.Fields("Shape").Value
    strTemp = m_recsStreets.Fields(STREETID_FLDNAME).Value
    lnTemp.SetMeasuresAsLength
    Set ptTemp = lnTemp.ReturnPointEvents(lnTemp.Length / 2)(0)
    Set polyTemp = MakePolyFromPoint(ptTemp, m_tol)
    collFlipPolys.Add polyTemp
    collFlipIds.Add strTemp
  End If
  m_recsStreets.MoveNext
Loop

'Replace the current select sets with the flip sets.
Set m_collSelPolys = collFlipPolys
Set m_collSelIds = collFlipIds

'Select streets based on the new selections.
Call SelectStreets

End Sub

Private Function FindStringInCollection(ByVal strValue As String) As Long

'Given a string, find that string in the collection.
'Return the index position if found.
'Return 0 if not found.

Dim i As Long
Dim idx As Long

idx = 0
For i = 1 To m_collSelIds.Count
  If m_collSelIds(i) = strValue Then
    idx = i
    Exit For
  End If
Next

FindStringInCollection = idx

End Function