frmmerestone.vb

界桩信息管理系统代码,VB写的。。。。。。。

        '创建测距工具
        CreateCustomRulerTool()

        '创建自定义信息工具
        CreateCustomInfoTool()

        '创建连接线
        CreateCustomLinkLineTool()

        '创建自定义增加具体界桩工具
        CreateCustomAddMereStoneTool()
    End Sub

    '---------------------------------------------------
    '   绑定图层
    '---------------------------------------------------
    Private Sub AfterAddPoint()
        ArrowMapTool()
        AxMaps.Enabled = False
        With UcMereStone1
            .DataControlEnable(True)
            .txtBox_mc.Focus()
        End With
    End Sub

    '---------------------------------------------------
    '   绑定图层
    '---------------------------------------------------
    Private Sub BindingLayer()

        '声明图层以及 MapX 自带的数据集
        Dim lyr As MapXLib.Layer = AxMaps.Layers.Item("MereStone")
        Dim ds As MapXLib.Dataset

        ds = AxMaps.Datasets.Add(MapXLib.DatasetTypeConstants.miDataSetLayer, lyr, lyr.Name)
        With lyr.LabelProperties
            .Dataset = ds
            .DataField = ds.Fields.Item("jzmc")
            lyr.KeyField = "jzbh"
        End With
    End Sub

    '---------------------------------------------------
    '   AddMereStone
    '       增加具体界桩
    '   Parameters:
    '       [in]    X,Y  增加具体界桩的X,Y坐标。
    '
    '   Remark:
    '       1.在地图上增加图元
    '       2.更新图元记录
    '       3.向数据库中增加记录
    '---------------------------------------------------
    Private Sub AddMereStone(ByVal X As Double, ByVal Y As Double)
        Dim currNode As MereStoneTreeNode
        Dim attCentre As Int32, attBox As Int32 = 0
        Dim after, befor As Integer, result As Boolean = True
        Dim f As MapXLib.Feature
        Dim key As Integer

        currNode = MereStoneTV.SelectedNode

        Try
            '增加地图图元
            f = AddMereStoneFeature(X, Y)
            key = UpdateMereStoneFeature(f, UcMereStone1.MereStoneData)
            If key = 0 Then
                MsgBox("新增加界桩失败,请重试！", MsgBoxStyle.Exclamation Or MsgBoxStyle.OKOnly, "系统提示")
                AxMaps.Layers.InsertionLayer.DeleteFeature(f)
            Else
                UcMereStone1.QueryDataByMereStone_BH(key)
            End If
        Catch ex As Exception
            MsgBox("新增加界桩失败,请重试！", MsgBoxStyle.Exclamation Or MsgBoxStyle.OKOnly, "系统提示")
            Exit Sub
        End Try
        ArrowMapTool()
        MereStoneTV.RefreshNode()
    End Sub

    '---------------------------------------------
    '   AddMereStoneFeature:
    '       在指定位置增加具体界桩地图图元
    '   Parameters:
    '       [in]    X,Y  增加具体界桩的X,Y坐标。
    '       [out]   新增的图元对象
    '---------------------------------------------
    Private Function AddMereStoneFeature(ByVal X As Double, ByVal Y As Double) As MapXLib.Feature
        Dim p As New MapXLib.Point
        Dim f As MapXLib.Feature
        Dim style As New MapXLib.Style

        Try
            With style
                .SymbolBitmapSize = 14.5
                With .SymbolFont
                    .Name = "MapInfo Cartographic"
                    .Charset = 2
                    .Weight = 400
                End With
                .SymbolFontShadow = True
                .SymbolFontColor = Convert.ToUInt32(MapXLib.ColorConstants.miColorBlue)
                .SymbolCharacter = 102
            End With
            'style.SymbolBitmapTransparent = True
            'style.SymbolBitmapName = "Menu.bmp"
        Catch ex As Exception

        End Try

        p.Set(X, Y)
        f = AxMaps.FeatureFactory.CreateSymbol(p, style)
        f = AxMaps.Layers.InsertionLayer.AddFeature(f)
        AxMaps.Layers.InsertionLayer.Refresh()

        AddMereStoneFeature = f
    End Function

    '---------------------------------------------
    '   UpdateMereStoneFeature:
    '       在指定位置增加具体界桩地图图元
    '   Parameters:
    '       [in]    f       要更新的图元
    '       [in]    data    具体界桩数据
    '       [out]   boolean 结果
    '---------------------------------------------
    Private Function UpdateMereStoneFeature(ByVal f As MapXLib.Feature, ByVal data As MereStoneData) As Integer
        Dim lyr As MapXLib.Layer = f.Layer
        Dim ds As MapXLib.Dataset
        Dim rvs As MapXLib.RowValues
        Dim retValue As Boolean = True
        Dim node As MereStoneTreeNode
        Dim pos As Integer
        Dim mapid As Integer

        Try
            'With UcMereStone1
            '    pos = Me.BindingContext(.MereStoneData, .MereStoneData.MereStone.TableName).Position.MaxValue
            'End With
            ds = AxMaps.Datasets.Item(1)
            rvs = ds.RowValues(f)

            'With data.MereStone
            '    mapid = f.FeatureID
            '    rvs.Item("jzbh").Value = mapid
            '    rvs.Item("jzmc").Value = data.Tables(.TableName).Rows(pos).Item(.jzmcColumn)
            '    rvs.Item("lx").Value = data.Tables(.TableName).Rows(pos).Item(.lxColumn)
            '    rvs.Item("cz").Value = data.Tables(.TableName).Rows(pos).Item(.czColumn)
            '    rvs.Item("bw").Value = data.Tables(.TableName).Rows(pos).Item(.bwColumn)
            '    rvs.Item("dj").Value = data.Tables(.TableName).Rows(pos).Item(.djColumn)
            '    rvs.Item("jzzfww_jl1").Value = data.Tables(.TableName).Rows(pos).Item(.jzzfww_jl1Column)
            '    rvs.Item("jzzfww_cfwj1").Value = data.Tables(.TableName).Rows(pos).Item(.jzzfww_cfwj1Column)
            '    rvs.Item("jzzwww_mc1").Value = data.Tables(.TableName).Rows(pos).Item(.jzzwww_mc1Column)
            '    rvs.Item("jzzfww_jl2").Value = data.Tables(.TableName).Rows(pos).Item(.jzzfww_jl2Column)
            '    rvs.Item("jzzfww_cfwj2").Value = data.Tables(.TableName).Rows(pos).Item(.jzzfww_cfwj2Column)
            '    rvs.Item("jzzwww_mc2").Value = data.Tables(.TableName).Rows(pos).Item(.jzzwww_mc2Column)
            '    rvs.Item("jzzfww_jl3").Value = data.Tables(.TableName).Rows(pos).Item(.jzzfww_jl3Column)
            '    rvs.Item("jzzfww_cfwj3").Value = data.Tables(.TableName).Rows(pos).Item(.jzzfww_cfwj3Column)
            '    rvs.Item("jzzwww_mc3").Value = data.Tables(.TableName).Rows(pos).Item(.jzzwww_mc3Column)
            '    rvs.Item("sm").Value = data.Tables(.TableName).Rows(pos).Item(.smColumn)
            '    rvs.Item("qt").Value = "无"
            '    rvs.Item("bz").Value = "无"
            'End With

            With data.MereStone
                mapid = f.FeatureID
                rvs.Item("jzbh").Value = mapid
                rvs.Item("jzmc").Value = "界桩-新增加"
                rvs.Item("lx").Value = "请输入"
                rvs.Item("cz").Value = "请输入"
                rvs.Item("bw").Value = "0°0′0″"
                rvs.Item("dj").Value = "0°0′0″"
                rvs.Item("jzzfww_jl1").Value = "请输入"
                rvs.Item("jzzfww_cfwj1").Value = "请输入"
                rvs.Item("jzzwww_mc1").Value = "请输入"
                rvs.Item("jzzfww_jl2").Value = "请输入"
                rvs.Item("jzzfww_cfwj2").Value = "请输入"
                rvs.Item("jzzwww_mc2").Value = "请输入"
                rvs.Item("jzzfww_jl3").Value = "请输入"
                rvs.Item("jzzfww_cfwj3").Value = "请输入"
                rvs.Item("jzzwww_mc3").Value = "请输入"
                rvs.Item("sm").Value = "请输入"
                rvs.Item("qt").Value = "无"
                rvs.Item("bz").Value = "无"
            End With

            f.Update(f, rvs)

            If Not (lyr.LabelProperties.Dataset Is Nothing) Then
                lyr.LabelProperties.Dataset.Refresh()
            End If
        Catch ex As Exception
            Return 0
        End Try

        Return mapid
    End Function

    '------------------------------------------
    '   DeleteMapFeature:
    '       删除图元界桩
    '------------------------------------------
    Private Function DeleteMapFeature() As Boolean
        Dim f As MapXLib.Feature
        Dim lyr As MapXLib.Layer = AxMaps.Layers.Item(MapsConstants.LAYERNAME_MereStone)
        Dim rvs As MapXLib.RowValues
        Dim ds As MapXLib.Dataset
        Dim result As Integer

        If lyr.Selection.Count > 0 Then
            If MsgBox("确定要删除此界桩吗？", MsgBoxStyle.Question Or MsgBoxStyle.YesNo Or MsgBoxStyle.DefaultButton2, "系统提示") = MsgBoxResult.No Then Return False

            f = lyr.Selection.Item(1)
            ds = AxMaps.Datasets.Item(1)
            rvs = ds.RowValues(f)

            '删除图元
            lyr.Selection.Remove(f)
            lyr.DeleteFeature(f)
            With MereStoneTV
                .CollapseAll()
            End With
            MsgBox("删除成功！", MsgBoxStyle.OKOnly Or MsgBoxStyle.Information, "系统提示")
            MereStoneTV.RefreshNode()
            UcMereStone1.ButtonEnable("init")
        End If
        Return True
    End Function

    '--------------------------------------------
    '  定位地图上的点。
    '--------------------------------------------
    Private Sub MapsFeatureGPS()
        Dim lyr As MapXLib.Layer
        Dim fs As MapXLib.Features
        Dim f As MapXLib.Feature
        Dim node As MereStoneTreeNode
        Dim ds As MapXLib.Dataset

        lyr = AxMaps.Layers.Item(MapsConstants.LAYERNAME_MereStone)
        ds = lyr.Datasets.Item(1)
        ds = AxMaps.Datasets.Add(MapXLib.DatasetTypeConstants.miDataSetLayer, lyr)
        node = MereStoneTV.SelectedNode

        If Not (lyr Is Nothing) Then
            With lyr
                Try
                    'MsgBox(ds.RowCount)
                    'fs = lyr.AllFeatures()
                    'MsgBox(fs.Count)
                    'For i As Integer = 1 To fs.Count Step 1
                    '    If fs.Item(i).FeatureID = node.mapID Then
                    '        f = fs.Item(i)
                    '        Exit For
                    '    End If
                    'Next
                    'MsgBox(lyr.AllFeatures.Count)
                    'MsgBox(node.bh)
                    'MsgBox(lyr.Name)
                    f = lyr.GetFeatureByID(node.mapID)  '.GetFeatureByKey(node.bh)
                    If f Is Nothing Then
                        MsgBox("找不到此界桩！", MsgBoxStyle.Exclamation Or MsgBoxStyle.OKOnly, "系统提示")
                        Return
                    End If
                    'MsgBox(ds.RowCount)
                    'MsgBox(node.bh)
                    'fs = .Search("jzbh=""" & node.bh & """")
                    'MsgBox(fs.Count)
                    'If fs.Count <= 0 Then
                    '    MsgBox("找不到此界桩！", MsgBoxStyle.Exclamation Or MsgBoxStyle.OKOnly, "系统提示")
                    '    Return
                    'End If
                    'f = fs.Item(1)
                    .Selection.ClearSelection()
                    .Selection.Add(f)
                    AxMaps.CenterX = f.CenterX
                    AxMaps.CenterY = f.CenterY
                Catch ex As Exception
                    'MsgBox(ex.ToString())
                    MsgBox("找不到此界桩！", MsgBoxStyle.Exclamation Or MsgBoxStyle.OKOnly, "系统提示")
                    Return
                End Try
            End With