frmmain.vb

用VB.NET开发的GeoMedia一个实例

                        CreateRecordset(objRS, cbNewFeature.Text, "")

                        NewGeometry(objGeometry, objRS)

                        '重新载入图例
                        ReLoadLegendEntry(objRS, Me.GMMapView1)

                        objGeometry = Nothing

                    Case "NewPoint"

                        '得到记录集
                        CreateRecordset(objRS, cbNewFeature.Text, "")

                        NewGeometry(gobjGeomEdit.GetGeometry(1), objRS)

                        '重新载入图例
                        ReLoadLegendEntry(objRS, Me.GMMapView1)
                End Select

                '判断是否选择了LOGO图形
                If MenuItem4.Checked Then
                    If Math.Abs(e.worldX - objPoint.Origin.X) < Math.Abs((objGeoline.Start.X - objGeoline.End.X) / 100) And _
                        Math.Abs(e.worldY - objPoint.Origin.Y) < Math.Abs((objGeoline.Start.Y - objGeoline.End.Y) / 100) Then
                        If objSymbol.index = Asc("Z") Then
                            objSymbol.index = Asc("A")
                        Else
                            objSymbol.index = objSymbol.index + 1
                        End If
                    End If

                End If

            Case 2              '鼠标右键
                Select Case MouseAction
                    Case "MeasureDistance"      '取消当前距离测量
                        objGeomDig.RemoveAllGeometries()
                        frmMeasureDistance1.txtDistance.Text = "0.00m"
                        frmMeasureDistance1.txtLength.Text = "0.00m"
                    Case "MeasureArea"          '取消当前面积测量
                        objGeomDig.RemoveAllGeometries()
                    Case Else

                        If gobjConnection.Status = 1 Then
                            objPoint1.X = e.windowX
                            objPoint1.Y = e.windowY
                            ContextMenu1.Show(Me.Panel1, objPoint1)

                        End If

                End Select
        End Select
        GMMapView1.CtlRefresh(False)
    End Sub

    Private Sub EventControl1_MouseDownEvent(ByVal sender As Object, ByVal e As AxGMEventControlLib._DGMEventControlEvents_MouseDownEvent) Handles EventControl1.MouseDownEvent
        On Error Resume Next
        Dim objGeom As Object
        Dim pntIndex As Short
        If e.button = 1 Then
            objPnt = New PBasic.point()
            objPnt.X = e.worldX
            objPnt.Y = e.worldY
            objPnt.Z = e.worldZ
            Select Case MouseAction
                Case "ZoomIn"   '放大
                    ZoomRectX1 = e.worldX
                    ZoomRectY1 = e.worldY
                    ZoomRectZ1 = e.worldZ
                    '如果是拉框矩形的第一点，则重新生成矩形图形
                    If objGeomDig.IsGeometryComplete Then
                        objGeomDig.RemoveAllGeometries()
                        objGeomDig.AppendGeometry(ZoomRect, ZoomLineStyle)
                    End If
                    objGeomDig.AppendPoint(objPnt)
                Case "ZoomOut"
                Case "MoveFeature"      '移动设备
                    gobjGeomEdit.BeginMove(objPnt)
                    GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctCrossHairZeroTolerance
                Case "EditGeometry"     '编辑
                    If Not snapPnt Is Nothing Then  '如果已捕获了一个在图形边线上的点
                        With gobjHandleStyle1       '设置选中的顶点的风格
                            .Color = RGB(200, 0, 200)
                            .Size = 5
                            .HandleMode = PView.StyleConstants.gmsHandleModeSolid
                            .HandleShape = PView.StyleConstants.gmsHandleShapeSquareX
                        End With
                        objPnt.X = snapPnt.X
                        objPnt.Y = snapPnt.Y
                        objPnt.Z = snapPnt.Z
                        '根据捕获状态决定是移动顶点还是添加顶点
                        '如果捕获的点是一个顶点则移动顶点，如果捕获的点是在线上的点则添加顶点
                        Select Case snapType
                            Case PClient.SnapTypeConstants.gmssOnVertex '''编辑顶点
                                Me.StatusBarPanelMessage.Text = "编辑;移动顶点"
                                gobjGeomEdit.UnSelectAllKeypoints(gobjGeomEdit.GeometryCount)   '取消所有顶点的选中状态
                                gobjGeomEdit.SelectKeypoint(gobjGeomEdit.GeometryCount, Myindex, gobjHandleStyle1) '设置选中的顶点状态
                                gobjGeomEdit.BeginMove(objPnt)      '移动
                                bMovePoint = True
                            Case PClient.SnapTypeConstants.gmssOnEndVertex '''编辑顶点
                                Me.StatusBarPanelMessage.Text = "编辑;移动顶点"
                                gobjGeomEdit.UnSelectAllKeypoints(gobjGeomEdit.GeometryCount)    '取消所有顶点的选中状态
                                gobjGeomEdit.SelectKeypoint(gobjGeomEdit.GeometryCount, Myindex, gobjHandleStyle1)  '设置选中的顶点状态
                                gobjGeomEdit.BeginMove(objPnt)      '移动
                                bMovePoint = True
                            Case PClient.SnapTypeConstants.gmssOnElement '''增加顶点
                                If gobjGeomEdit.IsEditable(gobjGeomEdit.GeometryCount, PClient.GeometryEditConstants.gmgeInsertVertex) Then     '图形允许插入顶点
                                    objGeom = gobjGeomEdit.GetGeometry(gobjGeomEdit.GeometryCount)
                                    Me.StatusBarPanelMessage.Text = "编辑;增加顶点"
                                    '取得图形对象
                                    pntIndex = PointOnline(objPnt, objGeom)                             '取得捕获点（鼠标现在所处位置）在图形中前一个顶点的序号
                                    If pntIndex = -1 Then
                                        gobjGeomEdit.SelectAllKeypoints(gobjGeomEdit.GeometryCount, gobjHandleStyle)
                                        Exit Sub
                                    End If
                                    gobjGeomEdit.InsertVertexAfter(objGeom, pntIndex, objPnt)           '插入
                                    StoreGeometry()                                                     '保存
                                    ReLoadGeoMetry(GMMapView1)                                          '重载图形
                                    gobjGeomEdit.SelectAllKeypoints(gobjGeomEdit.GeometryCount, gobjHandleStyle)    '选中所有顶点
                                    gobjGeomEdit.SelectKeypoint(gobjGeomEdit.GeometryCount, pntIndex + 1, gobjHandleStyle1) '重设添加的顶点的风格
                                    Me.StatusBarPanelMessage.Text = "编辑;点击添加顶点,按下左键拖动，按下DEL键删除"
                                    bMovePoint = False
                                End If
                        End Select
                    End If
            End Select
            GMMapView1.CtlRefresh(False)
        End If
    End Sub

    Private Sub EventControl1_MouseMoveEvent(ByVal sender As Object, ByVal e As AxGMEventControlLib._DGMEventControlEvents_MouseMoveEvent) Handles EventControl1.MouseMoveEvent
        On Error Resume Next
        Dim I, J As Integer
        Dim bExisted As Boolean
        gobjPnt.X = e.worldX
        gobjPnt.Y = e.worldY
        gobjPnt.Z = e.worldZ
        '在状态栏显示坐标
        Me.StatusBarPanelPointLocation.Text = Format(e.worldX, "###0.00") + "," + Format(e.worldY, "###0.00")
        Select Case e.button
            Case 0      '没有键按下时
                Select Case MouseAction
                    Case "NewLine"
                        objGeomDig.DynamicPoint(gobjPnt)

                    Case "NewArea"
                        objGeomDig.DynamicPoint(gobjPnt)

                    Case "NewText"
                        NewText.Origin.X = e.worldX
                        NewText.Origin.Y = e.worldY
                        NewText.Origin.Z = e.worldZ
                        NewText.text = tbNewText.Text + "  " '后缀的空格时为了GeometryEditService消除显示汉字的BUG

                        gobjGeomEdit.RemoveAllGeometries()
                        gobjGeomEdit.AppendGeometry(NewText, GetStyleObject(PClient.GConstants.gdbGraphicsText))

                    Case "NewPoint"
                        Dim objStyle As Object

                        NewPoint.Origin.X = e.worldX
                        NewPoint.Origin.Y = e.worldY
                        NewPoint.Origin.Z = e.worldZ

                        objStyle = GetStyleObject(PClient.GConstants.gdbPoint)
                        objStyle.size = 150

                        gobjGeomEdit.RemoveAllGeometries()
                        gobjGeomEdit.AppendGeometry(NewPoint, objStyle)

                    Case "Select"   '选择设备
                        objPntGeom.Origin.X = e.worldX
                        objPntGeom.Origin.Y = e.worldY
                        objPntGeom.Origin.Z = e.worldZ

                        objLocatedObjects.Clear()

                        objSmartLocSvrc.Locate(objPntGeom, GMMapView1.Dispatch, objLocatedObjects)
                        If objLocatedObjects.Count > 0 Then
                            For I = 1 To objLocatedObjects.Count
                                bExisted = False
                                For J = 1 To GMMapView1.HighlightedObjects.Count
                                    If objLocatedObjects.Item(I).IsEqual(GMMapView1.HighlightedObjects.Item(J)) Then
                                        bExisted = True
                                        Exit For
                                    End If
                                Next J
                                If Not bExisted Then
                                    GMMapView1.HighlightedObjects.Clear()
                                    GMMapView1.HighlightedObjects.Add(objLocatedObjects.Item(1))
                                End If
                            Next I
                        End If
                    Case "EditGeometry"     '编辑图形
                        If GMMapView1.MapViewSelectedObjects.Count > 0 Then '当已经存在选取的 Feature时，除执行添加点和移动过程中外，只捕获已选取的Feature
                            If SnapToGeometry(GMMapView1, objLocatedObjects, gobjPnt, snapPnt, snapType, Myindex) Then
                                '根据捕获的设备或点使用不同的光标形状
                                Select Case snapType
                                    Case PClient.SnapTypeConstants.gmssOnEndVertex
                                        GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctCrossHairOnEndPoint
                                        Me.StatusBarPanelMessage.Text = "编辑;移动顶点"
                                    Case PClient.SnapTypeConstants.gmssOnVertex
                                        GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctCrossHairOnVertex
                                        Me.StatusBarPanelMessage.Text = "编辑;移动顶点"
                                    Case PClient.SnapTypeConstants.gmssOnElement
                                        GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctCrossHairOnElement
                                        Me.StatusBarPanelMessage.Text = "编辑;添加顶点"
                                End Select
                            Else
                                GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctCrossHair
                                Me.StatusBarPanelMessage.Text = "编辑;点击添加顶点,按下左键拖动，按下DEL键删除"
                                snapPnt = Nothing
                            End If
                        Else
                            GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctCrossHair
                            snapPnt = Nothing
                        End If
                    Case "MeasureDistance"
                        objGeomDig.DynamicPoint(gobjPnt)
                        Dim pnts As PBasic.Points
                        Dim pntOrigin As PBasic.point
                        Dim dblDistance As Double
                        '计算鼠标当前位置与测量线最后一段的长度
                        pnts = vbCommon.GetEndVertices(objGeomDig.GetGeometry(objGeomDig.GeometryCount))
                        pntOrigin = pnts.Item(pnts.Count)
                        dblDistance = GetDistanceBetweenTwoPoints(gobjPnt, pntOrigin)
                        '显示测量结果
                        Me.frmMeasureDistance1.txtDistance.Text = Format(dblDistance, "###0.00") & " m"
                    Case "MeasureArea"
                        objGeomDig.DynamicPoint(gobjPnt)
                End Select
            Case 1      '鼠标右键
                Select Case MouseAction
                    Case "ZoomIn"   '拉框放大
                        objGeomDig.DynamicPoint(gobjPnt)
                    Case "ZoomOut"  '缩小

                        'objGeomDig.DynamicPoint(objPntZoom)
                    Case "Pan"      '平移
                        GMMapView1.Pan(e.worldX - objPnt.X, e.worldY - objPnt.Y, e.worldZ - objPnt.Z)
                    Case "MoveFeature"      '移动设备
                        gobjGeomEdit.Move(gobjPnt)
                    Case "EditGeometry"     '移动图形顶点
                        If bMovePoint = True Then
                            gobjGeomEdit.Move(gobjPnt)
                        End If
                End Select
        End Select
        GMMapView1.CtlRefresh(False)

        If GMMapView1.Legend.Visible = False Then
            Me.ToolBar1.Buttons(7).Pushed = False
            Me.mnuViewLegend.Checked = False
            If MouseAction = "Select" And Not Me.ToolBar1.Buttons(0).Pushed Then
                Me.ToolBar1.Buttons(0).Pushed = True
            End If
        End If
    End Sub

    Private Sub EventControl1_MouseUpEvent(ByVal sender As Object, ByVal e As AxGMEventControlLib._DGMEventControlEvents_MouseUpEvent) Handles EventControl1.MouseUpEvent
        On Error Resume Next
        Dim detalX, ratioX, mapY2, mapZ1, mapX1, mapY1, mapX2, mapZ2, ratioY, detalY As Double
        If e.button = 1 Then
            objPnt.X = e.worldX
            objPnt.Y = e.worldY
            objPnt.Z = e.worldZ

            Select Case MouseAction
                Case "ZoomIn"   '拉框放大
                    ZoomRectX2 = e.worldX
                    ZoomRectY2 = e.worldY
                    ZoomRectZ2 = e.worldZ
                    objGeomDig.AppendPoint(objPnt)
                    '如果拉框的范围太小则不认为是拉框放大，即是点击放大
                    If Math.Abs(ZoomRectX2 - ZoomRectX1) > 100 And Math.Abs(ZoomRectY2 - ZoomRectY1) > 100 Then
                        GMMapView1.ZoomArea(ZoomRectX1, ZoomRectY1, ZoomRectZ1, ZoomRectX2, ZoomRectY2, ZoomRectZ2)

                    Else
                        GMMapView1.Zoom(False, False, e.worldX, e.worldY, e.worldZ)
                    End If

                    '刷新LOGO
                    ReStartLogo()
                Case "MoveFeature"  '移动设备
                    gobjGeomEdit.EndMove(objPnt)      '移动结束
                    snapPnt = Nothing

                    StoreGeometry()                              '保存图形
                    ReLoadGeoMetry(GMMapView1)                   '更新显示
                    GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctNWArrow    '改变光标
                    MouseAction = "Select"