form1.frm

自己编写的基于VB+MO的图形元素编辑代码

                    Exit For
                End If
            Next pt
        Next ii
        SelEditRec.MoveNext
    Loop
    g_editLayer.Initialize dispMap, poly, curIndex
End Sub

Private Sub dispMap_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not g_dragger Is Nothing Then
        g_dragger.DragMove X, Y
    End If
End Sub

Private Sub dispMap_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not g_dragger Is Nothing Then
        g_dragger.DragFinish X, Y
        g_editLayer.MoveVertex dispMap.ToMapPoint(X, Y)
        Set g_dragger = Nothing
    End If
End Sub

Private Sub mnu_showVertex_Click()
    If mnu_showVertex.Checked = False Then
        mnu_showVertex.Checked = True
        m_boolEdit = True
    Else
        mnu_showVertex.Checked = False
        m_boolEdit = False
    End If
    Me.dispMap.TrackingLayer.Refresh True
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
  Dim bKey As String
  bKey = Button.Key
  Call doTask(bKey)
End Sub

Public Sub doTask(buttonKey As String)
    Select Case buttonKey
        Case "zoomin"
            Me.Toolbar1.Buttons("zoomout").Value = tbrUnpressed
            Me.Toolbar1.Buttons("pan").Value = tbrUnpressed
            Me.Toolbar1.Buttons("select").Value = tbrUnpressed
            
            Me.dispMap.MousePointer = moZoomIn
        Case "zoomout"
            Me.Toolbar1.Buttons("zoomin").Value = tbrUnpressed
            Me.Toolbar1.Buttons("pan").Value = tbrUnpressed
            Me.Toolbar1.Buttons("select").Value = tbrUnpressed
            
            Me.dispMap.MousePointer = moZoomOut
        Case "pan"
            Me.Toolbar1.Buttons("zoomin").Value = tbrUnpressed
            Me.Toolbar1.Buttons("zoomout").Value = tbrUnpressed
            Me.Toolbar1.Buttons("select").Value = tbrUnpressed
            
            Me.dispMap.MousePointer = moPan
        Case "select"
            Me.dispMap.MousePointer = moArrow
    End Select
End Sub

''放大
Private Sub ZoomIn()
    Dim trackrect1 As New MapObjects2.Rectangle, trackrect2 As New MapObjects2.Rectangle
    Set trackrect1 = Me.dispMap.TrackRectangle
    Set trackrect2 = dispMap.Extent
    If trackrect1.Left = trackrect1.Right Then '自由放大
        trackrect2.ScaleRectangle (0.5)
        Set dispMap.Extent = trackrect2
    Else
        Set dispMap.Extent = trackrect1        '指定放大
    End If
    
    Set trackrect1 = Nothing
    Set trackrect2 = Nothing
End Sub

''缩小
Private Sub ZoomOut()
    Dim trackRect As MapObjects2.Rectangle
    Set trackRect = dispMap.Extent
    trackRect.ScaleRectangle (1.5)
    Set dispMap.Extent = trackRect
    
    Set trackRect = Nothing
End Sub

''漫游
Public Sub ZoomPan()
    dispMap.Pan
End Sub

Private Sub Form_Load()
    legend1.setMapSource dispMap
    legend1.LoadLegend True
    mnu_showVertex.Checked = False
    
End Sub

Public Sub IdRec(X As Single, Y As Single)
On Error Resume Next

    Set LyrEdit = infoLyr

    Set g_selectedFeatures = Nothing
    Dim LocEdit As New MapObjects2.Point
    Dim theTol As Double

    Set LocEdit = dispMap.ToMapPoint(X, Y)
    theTol = dispMap.ToMapDistance(3 * Screen.TwipsPerPixelX)
    Set recEdit = Nothing
    
    Set recEdit = LyrEdit.SearchByDistance(LocEdit, theTol, "")
    Set g_selectedFeatures = recEdit
    Select Case LyrEdit.shapeType
        Case 23
'            Call selpoly
'            selptNum = 0
'            sellinNum = 0
        Case 22
'            Call selline
'            selnum = 0
'            selptNum = 0
        Case 21
'            Call selPoint
'            selnum = 0
'            sellinNum = 0
    End Select
    dispMap.TrackingLayer.Refresh True
End Sub

''获取所取的多边形
Private Sub SelPoly()

    If Not recEdit Is Nothing Then
       Set poly = recEdit.Fields("shape").Value
       ReDim Preserve fldArray(recEdit.Fields.Count)
        Dim i As Integer
        Dim fld As MapObjects2.Field
        For Each fld In recEdit.Fields
          fldArray(i) = fld.Value
          i = i + 1
        Next
        delnum = recEdit.Fields("shape").ValueAsString
        
        Set pts = poly.Parts(0)
    End If
    g_editLayer.Initialize dispMap, poly

End Sub

''重画图形
Sub ReDrawShape(rec As MapObjects2.Recordset)

    Dim curRec As MapObjects2.Recordset
    Set curRec = rec
    Dim sym1 As New MapObjects2.Symbol
    Dim sym As MapObjects2.Symbol
    
    Set sym = New MapObjects2.Symbol
    sym.SymbolType = moFillSymbol
    sym.Color = moBlack
    sym.Style = 0
    
    If m_boolEdit = False Then
        If Not curRec Is Nothing Then
            dispMap.DrawShape curRec, sym
        End If
    Else
        If Not curRec Is Nothing Then
            With sym1
                .SymbolType = moFillSymbol
                .Size = 5
                .Color = moYellow
            End With
            
            dispMap.DrawShape curRec, sym1

            Select Case curRec.Fields("shape").Type
                Case moPolygon
                    Call DrawVertex(curRec)
                Case moLine
                    Call DrawVertex(curRec)
                Case moPoint Or moPoints
                
            End Select
        End If
    End If
    
End Sub

''画出节点
Sub DrawVertex(rec As MapObjects2.Recordset)
    Dim curRec As MapObjects2.Recordset
    Set curRec = rec
    Dim curPoly As MapObjects2.Polygon
    Dim curLine As MapObjects2.line
    Dim pts As MapObjects2.points
    Dim sym2 As New MapObjects2.Symbol
    
    If curRec.Fields("shape").Type = moPolygon Then
        Do While Not curRec.EOF
            Set curPoly = curRec.Fields("shape").Value
            For Each pts In curPoly.Parts
                With sym2
                    .SymbolType = moPointSymbol
                    .Size = 5
                    .Color = moYellow
                End With
                
                Dim p As MapObjects2.Point
                For Each p In pts
                    dispMap.DrawShape p, sym2
                Next p
            Next pts
            curRec.MoveNext
        Loop
    End If
    
    If curRec.Fields("shape").Type = moLine Then
        Do While Not curRec.EOF
            Set curLine = curRec.Fields("shape").Value
            For Each pts In curLine.Parts
                With sym2
                    .SymbolType = moPointSymbol
                    .Size = 5
                    .Color = moYellow
                End With
                
                For Each p In pts
                    dispMap.DrawShape p, sym2
                Next p
            Next pts
            curRec.MoveNext
        Loop
    End If
End Sub