frmmain.vb

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

    Private Sub mnuEditEditGeometry_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mnuEditEditGeometry.Click
        On Error GoTo errhandle
        Dim gobjLineSelectStyle As New PView.LinearStyle()
        Dim objRS As GDO.GRecordset
        Dim sFieldName As String
        Dim objGeometry As Object
        Dim objGss As New PClient.GeometryStorageService()

        '重置环境
        ResetEnvironment()
        Me.StatusBarPanelMessage.Text = "编辑;点击添加顶点,按下左键拖动，按下DEL键删除"
        '定义图形进入编辑状态后的显示风格
        With gobjHandleStyle
            .Color = RGB(0, 0, 0)               '''黑色
            .HandleMode = 0                     'gmsHandleModeSolid --solid
            .HandleShape = 0                    'gmsHandleShapeSquare--Square 
            .Size = 2
            .StyleUnits = 2                     'gmsStyleUnitsView-- View Units (Pixels) 
        End With
        With gobjLineSelectStyle
            .Width = 1
            .Color = RGB(200, 200, 50)
            .LineStyle = 0                      'gmsLinearSolid--Solid 
            .StyleUnits = 2                     'gmsStyleUnitsView-- View Units (Pixels) 
        End With
        objLocatedObjects.Clear()
        '检查是否有选中的图形
        If GMMapView1.MapViewSelectedObjects.Count < 1 Then
            Me.StatusBarPanelMessage.Text = "请先选择一个图形"
        End If
        '定位选中的图形
        objLocatedObjects.Add(GMMapView1.MapViewSelectedObjects.Item(1))
        gobjGeomEdit.RemoveAllGeometries()
        '获取选中的图形
        objRS = objLocatedObjects.Item(1).Recordset
        sFieldName = GetGeometryFieldName(objRS)
        objRS.Bookmark = objLocatedObjects.Item(1).Bookmark
        rsGrecordset = objRS
        objGss.GetGeometry(objRS.GFields(sFieldName), objGeometry)
        '将选中的图形加入编辑对象中
        gobjGeomEdit.AppendGeometry(objGeometry, gobjLineSelectStyle)
        gobjGeomEdit.SelectAllKeypoints(objGeometry, gobjHandleStyle)
        MouseAction = "EditGeometry"
        GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctCrossHair
        Exit Sub
errhandle:
        Exit Sub
    End Sub

    Private Sub mnuToolMeasureDistance_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mnuToolMeasureDistance.Click
        '重置环境
        ResetEnvironment()
        '测量距离
        Me.StatusBarPanelMessage.Text = "测量距离;点击起始位置,沿待测方向画出线条"
        MouseAction = "MeasureDistance"
        GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctCrossHair

        '显示测量距离界面
        If Not frmMeasureDistance1 Is Nothing Then
            frmMeasureDistance1.Dispose()
        End If
        frmMeasureDistance1 = New FrmMeasureDistance()
        frmMeasureDistance1.Left = Me.Left + Me.Width / 2
        frmMeasureDistance1.Top = Me.Top + Me.Height / 2
        frmMeasureDistance1.Owner = Me
        frmMeasureDistance1.Show()
    End Sub

    Private Sub mnuToolMeasureArea_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mnuToolMeasureArea.Click
        '重置环境
        ResetEnvironment()
        '测量面积
        Me.StatusBarPanelMessage.Text = "测量面积;在图上画出待测面积的多边形"
        MouseAction = "MeasureArea"
        GMMapView1.MousePointer = MapviewLib.CursorTypeConstants.gmmvctCrossHair
    End Sub

    Private Sub contmnuZoomIn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles contmnuZoomIn.Click
        Me.mnuViewZoomIn_Click(sender, e)
    End Sub

    Private Sub contmnuZoomOut_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles contmnuZoomOut.Click
        Me.mnuViewZoomOut_Click(sender, e)
    End Sub

    Private Sub contmnuFit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles contmnuFit.Click
        Me.mnuViewFit_Click(sender, e)
    End Sub

    Private Sub contmnuPan_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles contmnuPan.Click
        Me.mnuViewPan_Click(sender, e)
    End Sub

    Private Sub contmnuProperty_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles contmnuProperty.Click
        Me.mnuViewProperty_Click(sender, e)
    End Sub

    Private Sub contmnuLegend_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles contmnuLegend.Click
        Me.mnuViewLegend_Click(sender, e)

        '控制图例项的选中
        contmnuLegend.Checked = Me.GMMapView1.Legend.Visible
    End Sub

    Public Sub OpenConnection()
        ' Display a common dialog to request an Access database
        ' file name.
        ' Algorithm:
        ' 1.  Initialize dialog parameters
        ' 2.  Display dialog
        ' 3.  If user said OK, attempt to open the database
        ' 4.  If user said Cancel, exit sub
        ' 5.  If open failed, display an error message and redisplay file dialog
        ' 6.  If open succeeded, create a DatabaseEntry and add the
        ' element to the global array

        Dim strFile As String
        On Error GoTo ErrorHandler
        ' setup and display the dialog
        strFile = BrowseForFile(Me.OpenFileDialog1)
        ' check status
        If (strFile = "") Then
            Exit Sub
        Else
            ' open database
            Cursor.Current = System.Windows.Forms.Cursors.WaitCursor
            On Error Resume Next
            If Not (gobjConnection Is Nothing) Then
                gobjConnection.Disconnect()
            End If
            On Error GoTo ErrorHandler

            OpenDatabase(1, strFile, "", "", "", "")
            LoadCoord(gobjConnection, Me.GMMapView1)

            Cursor.Current = System.Windows.Forms.Cursors.Default
            Me.StatusBarPanelMessage.Text = "数据库连接成功"
        End If
        Exit Sub

ErrorHandler:
        MsgBox(Err.Description, MSGBOX_ERROR, "数据库连接失败")
        Me.StatusBarPanelMessage.Text = "数据库连接失败"
    End Sub

    Private Function BrowseForFile(ByRef CDlg As OpenFileDialog) As String

        ' Handle Errors
        On Error GoTo UserCancelled

        ' Set FileOpen Dialog Filters
        CDlg.Filter = "(*.mdb)|*.mdb"

        ' Set Path To Current Path In Current Drive
        CDlg.InitialDirectory = CurDir()

        ' Set Filter The First In The Filter List
        CDlg.FilterIndex = 1
        ' If user cancels, trap it
        CDlg.RestoreDirectory = True

        ' Show FileOpen Dialog
        If CDlg.ShowDialog() = DialogResult.OK Then

            ' Return filename
            BrowseForFile = CDlg.FileName
        End If

        Exit Function

UserCancelled:
        BrowseForFile = ""
    End Function ' OpenFile


    Private Sub EventControl1_ClickEvent(ByVal sender As Object, ByVal e As AxGMEventControlLib._DGMEventControlEvents_ClickEvent) Handles EventControl1.ClickEvent
        Dim objRS As GDO.GRecordset

        Me.mnuEditMoveFeature.Enabled = False
        Me.mnuEditDeleteFeature.Enabled = False
        Me.objPnt.X = e.worldX
        Me.objPnt.Y = e.worldY
        Me.objPnt.Z = e.worldZ
        Dim objPoint1 As New Point()


        Select Case e.button
            Case 1      '鼠标左键
                Select Case MouseAction
                    Case "Property"     '属性
                    Case "Select"       '选择设备
                        objPntGeom.Origin.X = e.worldX
                        objPntGeom.Origin.Y = e.worldY
                        objPntGeom.Origin.Z = e.worldZ

                        objLocatedObjects.Clear()
                        GMMapView1.MapViewSelectedObjects.Clear()
                        gobjGeomEdit.RemoveAllGeometries()
                        '获取图形
                        objSmartLocSvrc.Locate(objPntGeom, GMMapView1.Dispatch, objLocatedObjects)
                        If objLocatedObjects.Count > 0 Then
                            '加入选择集
                            GMMapView1.MapViewSelectedObjects.Add(objLocatedObjects.Item(1))
                            '修改菜单显示状态
                            Me.mnuEditMoveFeature.Enabled = True
                            Me.mnuEditDeleteFeature.Enabled = True

                            Dim geoType As Long

                            objRS = objLocatedObjects.Item(1).Recordset
                            geoType = GetGeometryType(objRS)

                            If geoType <> 5 And geoType <> 10 Then
                                Me.mnuEditEditGeometry.Enabled = True
                            Else
                                Me.mnuEditEditGeometry.Enabled = False
                            End If
                        Else
                            Me.mnuEditMoveFeature.Enabled = False
                            Me.mnuEditDeleteFeature.Enabled = False
                            Me.mnuEditEditGeometry.Enabled = False
                        End If

                    Case "Center"       '居中
                        objPntGeom.Origin.X = e.worldX
                        objPntGeom.Origin.Y = e.worldY
                        objPntGeom.Origin.Z = e.worldZ

                        objLocatedObjects.Clear()
                        GMMapView1.HighlightedObjects.Clear()
                        GMMapView1.MapViewSelectedObjects.Clear()
                        gobjGeomEdit.RemoveAllGeometries()

                        objSmartLocSvrc.Locate(objPntGeom, GMMapView1.Dispatch, objLocatedObjects)
                        If objLocatedObjects.Count > 0 Then
                            GMMapView1.HighlightedObjects.Add(objLocatedObjects.Item(1))
                            GMMapView1.MapViewSelectedObjects.Add(objLocatedObjects.Item(1))
                        End If
                        GMMapView1.CenterSelectedObjects()

                    Case "ZoomOut"      '缩小
                        GMMapView1.Zoom(True, False, e.worldX, e.worldY, e.worldZ)

                        '刷新LOGO
                        ReStartLogo()

                    Case "MeasureDistance"      '测量距离
                        If objGeomDig.IsGeometryComplete Then
                            objGeomDig.RemoveAllGeometries()
                            objGeomDig.AppendGeometry(NewLine, ZoomLineStyle)
                        End If
                        objGeomDig.AppendPoint(objPnt)

                        With objMeas
                            .CoordSystem = GMMapView1.CoordSystemsMgr.CoordSystem
                            .ReferenceSpace = PCSS.CSSReferenceSpaceConstants.gmcssGeographic
                            .Geometry = objGeomDig.GetGeometry(1)
                        End With

                        Me.frmMeasureDistance1.txtDistance.Text = "0.00 m"
                        Me.frmMeasureDistance1.txtLength.Text = Format(objMeas.Length, "###0.00") & " m"
                    Case "MeasureArea"          '测量面积
                        If objGeomDig.IsGeometryComplete Then
                            objGeomDig.RemoveAllGeometries()
                            objGeomDig.AppendGeometry(NewArea, ZoomLineStyle)
                        End If
                        objGeomDig.AppendPoint(objPnt)
                    Case "NewLine", "NewArea"  '插入面型图素和插入线型图素
                        gobjPnt.X = e.worldX
                        gobjPnt.Y = e.worldY
                        gobjPnt.Z = e.worldZ
                        If objGeomDig.IsGeometryComplete Then
                            objGeomDig.RemoveAllGeometries()

                            If MouseAction = "NewLine" Then
                                objGeomDig.AppendGeometry(NewLine, ZoomLineStyle)
                            Else
                                objGeomDig.AppendGeometry(NewArea, ZoomLineStyle)
                            End If
                        End If

                        objGeomDig.AppendPoint(gobjPnt)

                    Case "NewText"  '插入点和文本
                        Dim objGeometry As Object

                        objGeometry = gobjGeomEdit.GetGeometry(1)

                        objGeometry.text = Trim(objGeometry.text)

                        '得到记录集