geometryop.vb

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

Imports VBCommon
Namespace Common
    Public Class GeometryOP


        Shared Function LoadCoord(ByRef ActiveConnection As PClient.Connection, ByRef OcxMapView As AxMapviewLib.AxGMMapView) As Object
            'Load coordinate system from gdatabase, then assign to mapview
            Dim i As Integer
            Dim sSQL As String
            Dim Flds() As Object
            Dim FldTemp As Object
            Dim objRsCoord As PClient.GRecordset
            Dim objCoordSysMgr As Object
            Dim objDB As PClient.GDatabase

            objCoordSysMgr = CreateObject("CoordSystemsMgr")
            sSQL = "Select * From GCoordSystem"
            objDB = ActiveConnection.Database
            objRsCoord = objDB.OpenRecordset(sSQL, PClient.GConstants.gdbOpenDynaset)
            ReDim Flds(objRsCoord.GFields.Count - 1)

            Do While objRsCoord.EOF <> True
                FldTemp = objRsCoord.GetRows(1)
                For i = 0 To objRsCoord.GFields.Count - 1
                    Flds(i) = FldTemp(i, 0)
                Next i
            Loop
            objRsCoord = Nothing
            objCoordSysMgr.CoordSystem.LoadFromGCoordSystemTableRowFormat(Flds)
            OcxMapView.CoordSystemsMgr = objCoordSysMgr
            objCoordSysMgr = Nothing
        End Function

        Shared Sub OpenDatabase(ByRef iDataBaseType As Short, ByRef Location As String, ByRef Server As String, ByRef DataBaseName As String, ByRef USERID As String, ByRef Password As String)
            '1 open access database
            '2 open sqlserver database
            '3 open oracle database
            Dim conKeyWord As String
            On Error GoTo ErrorHandler
            On Error Resume Next

            gobjConnection.Disconnect()
            With gobjConnection
                If iDataBaseType = 1 Then
                    .Type = "Access.GDatabase"
                    .Location = Location
                ElseIf iDataBaseType = 2 Then
                    .Type = "SQLServerRW.GDatabase"
                    .Location = "Sql Server"
                    .ConnectionName = "xxx"
                    conKeyWord = "Uid=" & "libin" & ";Pwd=" & "123" & ";Database=" & "geomedia" & ";SERVER=" & "libin"
                    .ConnectInfo = conKeyWord
                    'MsgBox .ConnectInfo
                    .Mode = PClient.ConnectionConstants.gmcModeReadWrite
                End If
                .Connect()
            End With
            Exit Sub
ErrorHandler:
            MsgBox(Err.Description, MSGBOX_ERROR, "打开数据库出错")
        End Sub

        Shared Function GetFeatureNameList(Optional ByVal bGeoFeature As Boolean = False) As ArrayList
            On Error GoTo ErrorHandler

            Dim alFeatureName As ArrayList
            Dim objMDSrvc As New GMService.MetadataService()
            Dim vTableList As Object
            Dim tmask As Integer
            Dim i As Short

            alFeatureName = New ArrayList()
            If gobjConnection.Status = PClient.ConnectionConstants.gmcStatusOpen Then
                objMDSrvc.Connection = gobjConnection
                If bGeoFeature Then
                    tmask = PService.MetadataTableConstants.gmmtGraphic + PService.MetadataTableConstants.gmmtAnySpatial + _
                            PService.MetadataTableConstants.gmmtAreal + PService.MetadataTableConstants.gmmtLinear + _
                            PService.MetadataTableConstants.gmmtPoint
                Else
                    tmask = 1 + 2 + 4 + 8 + 16 + 32 + 128
                End If

                objMDSrvc.GetTables(tmask, vTableList)
                For i = 0 To (UBound(vTableList) - LBound(vTableList) - 1)
                    alFeatureName.Add(vTableList(i))
                Next i
                objMDSrvc = Nothing
            Else
                MsgBox("数据库连接未打开", MsgBoxStyle.OKOnly, "错误")
            End If
            Return alFeatureName

ErrorHandler:
            MsgBox(Err.Description, MSGBOX_ERROR, "错误")
            objMDSrvc = Nothing

        End Function

        Shared Sub CreateRecordset(ByRef objRS As PClient.GRecordset, ByVal strActiveTableName As String, ByVal strFilter As String)
            ' this function display a form to select a database/feature class
            ' Once selected, the recordset is returned to the calling function

            ' Algorithm:
            ' 1.  check to ensure at least one connection exists
            ' 2.  call frmSelectFeature.GetSelectFeatureInfo to display the form with
            '     databases and tables properly populated on the form, and get the
            '     connection and table the user chose
            ' 3.  create a recordset using OriginatingPipe

            On Error GoTo ErrorHandler

            'Check to ensure at least one connection exists.


            Dim objOP As PClient.OriginatingPipe
            If strActiveTableName <> "" Then
                gobjConnection.CreateOriginatingPipe(objOP)
                objOP.Table = strActiveTableName
                objOP.Filter = strFilter
                objRS = objOP.OutputRecordset
                objOP = Nothing
            End If
            Exit Sub
ErrorHandler:
            MsgBox(Err.Description, MSGBOX_ERROR, "CreateRecordset Error")
        End Sub

        Shared Sub DisplayTheLegendEntry(ByRef objLE As PView.RecordLegendEntry, ByRef OcxMapView As AxMapviewLib.AxGMMapView)
            On Error GoTo ErrorHandler
            Dim objLegend As PView.Legend
            If Not (objLE Is Nothing) Then
                If OcxMapView.Legend Is Nothing Then
                    OcxMapView.Legend = New PView.Legend()
                End If
                objLegend = OcxMapView.Legend
                If objLE.ValidateSource Then
                    If objLegend.LegendEntries.Count = 0 Then

                        objLegend.LegendEntries.Append(objLE)
                        objLE.LoadData()
                        OcxMapView.Fit()
                    Else
                        objLegend.LegendEntries.Append(objLE, 1)
                        objLE.LoadData()
                    End If
                    OcxMapView.Fit()
                    OcxMapView.CtlRefresh(True)
                End If
                objLegend = Nothing
            End If

            Exit Sub

ErrorHandler:
            MsgBox(Err.Description, MSGBOX_ERROR, "图例显示出错")
            On Error Resume Next
            objLegend = Nothing

        End Sub

        Shared Function GetLegendEntry(ByRef objRS As PClient.GRecordset, ByRef OcxMapView As AxMapviewLib.AxGMMapView) As PView.RecordLegendEntry

            On Error GoTo ErrorHandler
            Dim GLegend As PView.RecordLegendEntry

            'Create the RecordLegendEntry returned by this function.
            GLegend = CreateObject("GeoMedia.RecordLegendEntry")

            'Create the ExtendedPropertySet of the input recordset.
            Dim objExt As Object
            objExt = objRS.GetExtension("ExtendedPropertySet")

            'Get the name of the geometry field.
            GLegend.GeometryFieldName = objExt.GetValue("PrimaryGeometryFieldName")
            Dim objfield As PClient.GField
            If GLegend.GeometryFieldName = "" Then
                ' this will be true when the table only contains a text field
                For Each objfield In objRS.GFields
                    If objfield.Type = PClient.GConstants.gdbSpatial Or objfield.Type = PClient.GConstants.gdbGraphic Then
                        GLegend.GeometryFieldName = objfield.Name
                        Exit For
                    End If
                Next objfield
                objfield = Nothing
            End If

            'Get the name of the recordset and set that to be the legend entry title.
            GLegend.Title = objExt.GetValue("Name")

            'Get the geometry type and use that as input to get a style object for this
            'legend entry.
            Dim iGeometryType As Short
            iGeometryType = objExt.GetValue("GeometryType")
            GLegend.Style = GetStyleObject(iGeometryType)
            ' name will be blank if the recordset is derived so default it
            If GLegend.Title = "" Then
                GLegend.Title = objRS.GFields(0).SourceTable
            End If

            'Run the recordset through the CSSTransformPipe to transform the geometries to
            'the CSS of the mapview.  The definition of the transform occurred at the time of the
            'recordset creation
            Dim objCSSPipe As New PDBPipe.CSSTransformPipe()
            objCSSPipe.InputRecordset = objRS
            objCSSPipe.CoordSystemsMgr = OcxMapView.CoordSystemsMgr
            objCSSPipe.InputGeometryFieldName = GLegend.GeometryFieldName
            objCSSPipe.OutputCSGUID = OcxMapView.CoordSystemsMgr.CoordSystem.GUID

            GLegend.Recordset = objCSSPipe.OutputRecordset

            objExt = Nothing
            objCSSPipe = Nothing
            Return GLegend
            'Exit Function

ErrorHandler:
            MsgBox(Err.Description, MSGBOX_ERROR, "获取图例出错")
            On Error Resume Next
            objExt = Nothing
            objCSSPipe = Nothing

        End Function

        Shared Function ReLoadLegendEntry(ByRef objRS As PClient.GRecordset, ByRef OcxMapView As AxMapviewLib.AxGMMapView) As Object
            On Error GoTo errhandle
            Dim objLE As PView.RecordLegendEntry
            Dim i As Short
            Dim isExist As Boolean
            Dim IndexLegendEntry As Short
            Dim objStyle As Object
            Dim strTitle As String

            objLE = GetLegendEntry(objRS, OcxMapView)
            If OcxMapView.Legend.LegendEntries.Count = 0 Then
                DisplayTheLegendEntry(objLE, OcxMapView)
            Else
                For i = 1 To OcxMapView.Legend.LegendEntries.Count
                    If objRS.GFields(0).SourceTable = OcxMapView.Legend.LegendEntries(i).Recordset.GFields(0).SourceTable Then
                        IndexLegendEntry = i
                        objStyle = OcxMapView.Legend.LegendEntries(i).Style
                        strTitle = OcxMapView.Legend.LegendEntries(i).Title
                        isExist = True
                        Exit For
                    Else
                        isExist = False
                    End If
                Next i

                If isExist Then
                    OcxMapView.Legend.LegendEntries.Remove(IndexLegendEntry)