点线编辑

点线的编辑
Option Explicit
Private recsOrigin As MapObjects2.Recordset
Private lnOrigin As MapObjects2.Line
Private lnDestination As MapObjects2.Line
Private lnDrag As MapObjects2.Line
Private ptsOrigin As MapObjects2.Points
Private ptsDestination As MapObjects2.Points
Private ptDrag As MapObjects2.Point
Private bDragging As Boolean
Private symOrigin As MapObjects2.Symbol
Private symDestination As MapObjects2.Symbol
Private symVertices As MapObjects2.Symbol
Private symLineDrag As MapObjects2.Symbol
Private symPtDrag As MapObjects2.Symbol
Private iShortPart As Integer
Private iShortVert As Long
Private iSelTol As Integer
Private iSnapTol As Integer

Private Sub Form_Load()

‘添加新图层
Dim dc As New MapObjects2.DataConnection
Dim mlyr As New MapObjects2.MapLayer
dc.Database = App.Path
dc.Connect
Set mlyr.GeoDataset = dc.FindGeoDataset("lines")
mlyr.Symbol.Color = moBlue
Map1.Layers.Add mlyr

'放大
Dim rect As MapObjects2.Rectangle
Set rect = Map1.FullExtent
rect.ScaleRectangle 1.1
Set Map1.FullExtent = rect
Set Map1.Extent = rect

'符号属性设定
Set symOrigin = New MapObjects2.Symbol
With symOrigin
  .SymbolType = moLineSymbol
  .Style = moSolidLine
  .Color = moGreen
  .Size = 2
End With
Set symDestination = New MapObjects2.Symbol
With symDestination
  .SymbolType = moLineSymbol
  .Style = moSolidLine
  .Color = moRed
  .Size = 2
End With
Set symVertices = New MapObjects2.Symbol
With symVertices
  .SymbolType = moPointSymbol
  .Style = moSquareMarker
  .Size = 5
End With

'设定脱动的线和接点的样式
Map1.TrackingLayer.SymbolCount = 2
With Map1.TrackingLayer.Symbol(0)
  .SymbolType = moPointSymbol
  .Style = moBlack
  .Size = 5
End With
With Map1.TrackingLayer.Symbol(1)
  .SymbolType = moLineSymbol
  .Style = moSolidLine
  .Color = moBlack
  .Size = 1
End With


End Sub

Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)

'选择的线存在，绘制出来
If Not lnDestination Is Nothing Then
  Map1.DrawShape lnDestination, symDestination
  symVertices.Color = moRed
  Map1.DrawShape ptsDestination, symVertices
End If
If Not lnOrigin Is Nothing Then
  Map1.DrawShape lnOrigin, symOrigin
  symVertices.Color = moGreen
  Map1.DrawShape ptsOrigin, symVertices
End If

End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim recsDestination As MapObjects2.Recordset
Dim pt As MapObjects2.Point
Dim tol As Double
Dim i As Long, j As Long

Set pt = Map1.ToMapPoint(X, Y)

'Get the selection tolerance; handle invalid input
If IsNumeric(txtSelTol.Text) Then
  If txtSelTol.Text > 32767 Then
    txtSelTol.Text = "3"
  End If
Else
  txtSelTol.Text = "3"
End If
iSelTol = CInt(txtSelTol.Text)
  
tol = Map1.ToMapDistance(iSelTol * Screen.TwipsPerPixelX)

Select Case True
  Case Option1  'SELECT A LINE TO EDIT
    Set recsOrigin = Map1.Layers(0).SearchByDistance(pt, tol, "")
    If Not recsOrigin.EOF Then
      Set lnOrigin = recsOrigin.Fields("Shape").Value
      Set ptsOrigin = New MapObjects2.Points
      For i = 0 To lnOrigin.Parts.Count - 1
        For j = 0 To lnOrigin.Parts(i).Count - 1
          ptsOrigin.Add lnOrigin.Parts(i)(j)
        Next j
      Next i
     Else
      Set lnOrigin = Nothing
      Set ptsOrigin = Nothing
    End If
    Option2.Value = True
  Case Option2  'SELECT A LINE TO SNAP TO
    Set recsDestination = Map1.Layers(0).SearchByDistance(pt, tol, "")
    If Not recsDestination.EOF Then
      Set lnDestination = recsDestination.Fields("Shape").Value
      Set ptsDestination = New MapObjects2.Points
      For i = 0 To lnDestination.Parts.Count - 1
        For j = 0 To lnDestination.Parts(i).Count - 1
          ptsDestination.Add lnDestination.Parts(i)(j)
        Next j
      Next i
     Else
      Set lnDestination = Nothing
      Set ptsDestination = Nothing
    End If
    Option3.Value = True
  Case Option3  'MOVE A VERTEX TO CHANGE THE EDIT SHAPE
    bDragging = True
    Set lnDrag = New MapObjects2.Line
    Call FindClosestVertex(lnOrigin, pt)
End Select

Map1.Refresh
    
End Sub

Private Sub FindClosestVertex(ln As MapObjects2.Line, pt As MapObjects2.Point)
下面的意思应该比较清楚拉，呵呵
'Using "pt", find the closest vertex on "ln".  That closest
'vertex becomes "ptDrag"

Dim iShortPart As Integer
Dim dShortDist As Double, dThisDist As Double
Dim i As Integer, j As Long
Dim ptsShortPart As MapObjects2.Points
Dim ptsDrag As New MapObjects2.Points
Dim bFound As Boolean

bFound = False

'Get the selection tolerance; handle invalid input
If IsNumeric(txtSelTol.Text) Then
  If txtSelTol.Text > 32767 Then
    txtSelTol.Text = "3"
  End If
Else
  txtSelTol.Text = "3"
End If
iSelTol = CInt(txtSelTol.Text)

'Find the closest vertex to the mouse click
dShortDist = Map1.ToMapDistance(iSelTol * Screen.TwipsPerPixelX)
For i = 0 To ln.Parts.Count - 1
  For j = 0 To ln.Parts(i).Count - 1
    dThisDist = pt.DistanceTo(ln.Parts(i)(j))
    If dThisDist < dShortDist Then
      bFound = True
      dShortDist = dThisDist
      iShortPart = i
      iShortVert = j
    End If
  Next j
Next i

If Not bFound Then
  bDragging = False
  Exit Sub
End If

Set ptDrag = ln.Parts(iShortPart)(iShortVert)

'Create a rubber band line
Set ptsShortPart = ln.Parts(iShortPart)
Select Case iShortVert
  Case 0
    ptsDrag.Add ptsShortPart(0)
    ptsDrag.Add ptsShortPart(1)
  Case ptsShortPart.Count - 1
    ptsDrag.Add ptsShortPart(iShortVert - 1)
    ptsDrag.Add ptsShortPart(iShortVert)
  Case Else
    ptsDrag.Add ptsShortPart(iShortVert - 1)
    ptsDrag.Add ptsShortPart(iShortVert)
    ptsDrag.Add ptsShortPart(iShortVert + 1)
End Select

lnDrag.Parts.Add ptsDrag

Map1.TrackingLayer.AddEvent ptDrag, 0
Map1.TrackingLayer.AddEvent lnDrag, 1

End Sub

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim pt As MapObjects2.Point
Set pt = Map1.ToMapPoint(X, Y)

Dim tl As MapObjects2.TrackingLayer
Set tl = Map1.TrackingLayer

'If dragging a vertex, change the rubber band shape
'to the mouse's new location.
If bDragging Then
  tl.Event(0).MoveTo pt.X, pt.Y
  tl.RemoveEvent 1
  lnDrag.Parts(0).Set 1, pt
  tl.AddEvent lnDrag, 1
  tl.Refresh True
End If

End Sub

Private Sub Map1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim pt As MapObjects2.Point
Set pt = Map1.ToMapPoint(X, Y)

'If currently dragging, then find the vertex on the destination
'which is closest to the mouse.  If that closest vertex is within
'30 PIXELS from the mouse, then snap the edit line's vertex to
'the destination line's vertex.
If bDragging Then
  lnOrigin.Parts(iShortPart).Set iShortVert, ClosestDestVertex(pt)
  recsOrigin.Edit
  Set recsOrigin.Fields("Shape").Value = lnOrigin
  recsOrigin.Update
  recsOrigin.StopEditing
  Set ptsOrigin = lnOrigin.Parts(iShortPart)
  Set lnDrag = Nothing
  Set ptDrag = Nothing
  bDragging = False
End If

Map1.TrackingLayer.ClearEvents
Map1.Refresh

End Sub

Private Function ClosestDestVertex(pt As MapObjects2.Point) As MapObjects2.Point

'Given "pt", find the closest point in "ptsDestination".
'Return the resulting point.   If no points in
'"ptsDestination" are within 30 PIXELS, then return the
'input point and edit the line, but do not snap.

Dim ptTemp As New MapObjects2.Point
Dim dThisDist As Double, dShortDist As Double
Dim i As Long

ptTemp.X = pt.X
ptTemp.Y = pt.Y

'Get the snapping tolerance; handle invalid input
If IsNumeric(txtSnapTol.Text) Then
  If txtSnapTol.Text > 32767 Then
    txtSnapTol.Text = "30"
  End If
Else
  txtSnapTol.Text = "30"
End If
iSnapTol = CInt(txtSnapTol.Text)

'Convert snap tolerance in pixels into map units
dShortDist = Map1.ToMapDistance(iSnapTol * Screen.TwipsPerPixelX)

'Find the closest vertex inside the snapping tolerance, otherwise
'simply return the same point that was entered
For i = 0 To ptsDestination.Count - 1
  dThisDist = pt.DistanceTo(ptsDestination(i))
  If dThisDist < dShortDist Then
    dShortDist = dThisDist
    ptTemp.X = ptsDestination(i).X
    ptTemp.Y = ptsDestination(i).Y
  End If
Next i

Set ClosestDestVertex = ptTemp

End Function