form1.frm

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

VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "Mo20.ocx"
Object = "{C7FC2F7C-0688-11D5-B2F8-000102D87123}#1.0#0"; "MO21Legend.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5295
   ClientLeft      =   165
   ClientTop       =   855
   ClientWidth     =   6960
   LinkTopic       =   "Form1"
   ScaleHeight     =   5295
   ScaleWidth      =   6960
   StartUpPosition =   3  'Windows Default
   Begin MO21legend.legend legend1 
      Height          =   4335
      Left            =   120
      TabIndex        =   2
      Top             =   720
      Width           =   1695
      _ExtentX        =   2990
      _ExtentY        =   7646
      BackColor       =   -2147483644
      ForeColor       =   -2147483630
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin MapObjects2.Map dispMap 
      Height          =   4455
      Left            =   1920
      TabIndex        =   1
      Top             =   720
      Width           =   4935
      _Version        =   131072
      _ExtentX        =   8705
      _ExtentY        =   7858
      _StockProps     =   225
      BackColor       =   16777215
      BorderStyle     =   1
      Contents        =   "Form1.frx":0000
   End
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   6360
      Top             =   4680
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   4
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Form1.frx":00D2
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Form1.frx":0425
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Form1.frx":0778
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "Form1.frx":0ACB
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.Toolbar Toolbar1 
      Align           =   1  'Align Top
      Height          =   615
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   6960
      _ExtentX        =   12277
      _ExtentY        =   1085
      ButtonWidth     =   820
      ButtonHeight    =   926
      Appearance      =   1
      ImageList       =   "ImageList1"
      _Version        =   393216
      BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628} 
         NumButtons      =   4
         BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "放大"
            Key             =   "zoomin"
            ImageIndex      =   1
            Style           =   2
         EndProperty
         BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "缩小"
            Key             =   "zoomout"
            ImageIndex      =   2
            Style           =   2
         EndProperty
         BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "漫游"
            Key             =   "pan"
            ImageIndex      =   3
            Style           =   2
         EndProperty
         BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628} 
            Caption         =   "选择"
            Key             =   "select"
            ImageIndex      =   4
            Style           =   2
         EndProperty
      EndProperty
   End
   Begin VB.Menu mnu_edit 
      Caption         =   "编辑"
      Begin VB.Menu mnu_showVertex 
         Caption         =   "显示节点"
      End
      Begin VB.Menu mnu_addpt 
         Caption         =   "线上加点"
      End
      Begin VB.Menu mnu_save 
         Caption         =   "保存"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim curX As Single, curY As Single      ''记录鼠标当前所处的位置
Dim m_boolEdit As Boolean       ''定义是否图形编辑
Dim m_boolDraw As Boolean       ''定义是否图形绘画
Dim drawPt As Boolean

Dim infoLyr As MapObjects2.MapLayer
Dim LyrEdit As MapObjects2.MapLayer     ''定义编辑图层
Dim recEdit As MapObjects2.Recordset    ''定义编辑数据集
''***********选择点线面***************
Public g_selectedFeatures As MapObjects2.Recordset      ''定义选择数据集

Dim g_editLayer As New EditLayer
Dim g_dragger As DragFeedback
Dim curIndex As Integer    ''定义当前图层号
Dim iParts As Integer       ''定义第几个parts

Private Sub dispMap_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)
    Call ReDrawShape(recEdit)
    Dim sym3 As MapObjects2.Symbol
'    If drawPt = True Then
'        With sym3
'            .SymbolType = moPointSymbol
'            .Style = 1
'            .Size = 5
'            .Color = moYellow
'        End With
'            mapdisp.DrawShape pts(selVertex), sym3
'    End If
    
    If m_boolDraw = True Then   'boolSplit = True Or
        g_editLayer.Draw
    End If
End Sub

Private Sub dispMap_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        If Me.Toolbar1.Buttons("zoomin").Value = tbrPressed Then
            Call ZoomIn
        ElseIf Me.Toolbar1.Buttons("zoomout").Value = tbrPressed Then
            Call ZoomOut
        ElseIf Me.Toolbar1.Buttons("pan").Value = tbrPressed Then
            Call ZoomPan
        ElseIf Me.Toolbar1.Buttons("select").Value = tbrPressed Then
        
            curIndex = legend1.getActiveLayer       ''获取当前活动图层的序数
            
            If dispMap.Layers.Count = 0 Then Exit Sub
            If dispMap.Layers.Count = 1 And _
                dispMap.Layers(0).LayerType = moImageLayer Then Exit Sub
            If curIndex <> -1 Then      ''选中当前某一图层
            
                Set infoLyr = dispMap.Layers(curIndex)      ''获取选中的图层
                
                curX = X: curY = Y
                
                If m_boolEdit = False Then     ''是否处于编辑状态
                    Call IdRec(curX, curY)
                ElseIf m_boolEdit = True Then   ''处于编辑状态，进行节点编辑
                
                    If infoLyr.shapeType = moShapeTypePolygon Then
                        Call SelEditPoly
                    ElseIf infoLyr.shapeType = moShapeTypePoint Then
                    
                    End If
                
                    m_boolDraw = g_editLayer.SelectVertex(dispMap.ToMapPoint(X, Y))
                    If m_boolDraw = True Then
                        Set g_dragger = New DragFeedback
                        g_dragger.DragStart g_editLayer.VertexHandle(iParts), dispMap, X, Y
                    End If
                    
            
                End If
            Else
                MsgBox "对不起，当前没有激活的图层", vbYesNo + vbInformation, "查询提示"
                Exit Sub
            End If
            
        End If
    End If
End Sub

Private Sub SelEditPoly()
    
    Dim pt As MapObjects2.Point
    Dim tol As Double
    tol = dispMap.ToMapDistance(60)     ''设置捕获距离
    Dim pts As MapObjects2.points
    Dim poly As MapObjects2.Polygon
    Dim SelPoly As MapObjects2.Polygon
    Dim curLyr As MapObjects2.MapLayer
    Set curLyr = dispMap.Layers(curIndex)
    Dim SelEditRec As MapObjects2.Recordset
    Set SelEditRec = curLyr.Records

    Do While Not SelEditRec.EOF
        Set poly = SelEditRec.Fields("shape").Value
        iParts = -1
        For ii = 0 To poly.Parts.Count - 1
            Set pts = poly.Parts(ii)
            iParts = iParts + 1
            For Each pt In pts
                If pt.DistanceTo(dispMap.ToMapPoint(X, Y)) < tol Then
                    Set SelPoly = poly