geometryop.vb

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

            Dim objfield As PClient.GField
            ' this will be true when the table only contains a text field
            For Each objfield In InputRecordset.GFields
                If objfield.Type = PClient.GConstants.gdbSpatial Or objfield.Type = PClient.GConstants.gdbGraphic Then
                    'Get the geometry type 
                    GetGeometryType = objExt.GetValue("GeometryType")
                    Exit For
                End If
            Next objfield
            objfield = Nothing
            Exit Function
errhandle:
            MsgBox("获取图形类型出错！")
            objfield = Nothing
        End Function

        '----------------------------------------------------------------------------------------------
        ' 在记录集里编辑图形
        ' Intergraph 2005.1
        '----------------------------------------------------------------------------------------------
        Shared Function StoreGeometry() As Boolean
            Dim objGss As PClient.GeometryStorageService
            Dim objGeom As Object
            Dim objfield As GDO.GField

            On Error GoTo MyErr

            objGss = CreateObject("GeoMedia.GeometryStorageService")
            objGeom = gobjGeomEdit.GetGeometry(gobjGeomEdit.GeometryCount)
            rsGrecordset.Edit()
            objGss.SetGeometry(rsGrecordset.GFields(GetGeometryFieldName(rsGrecordset)), objGeom)
            rsGrecordset.Update()

            StoreGeometry = True
            objGeom = Nothing
            objGss = Nothing
            Exit Function
MyErr:
            StoreGeometry = False
            objGeom = Nothing
            objGss = Nothing
        End Function

        '----------------------------------------------------------------------------------------------
        ' 在记录集里加入图形
        ' Intergraph 2005.1
        '----------------------------------------------------------------------------------------------
        Shared Function NewGeometry(ByVal Geometry As Object, ByVal objRS As GDO.GRecordset) As Boolean
            On Error GoTo MyErr
            Dim objGSS As PClient.GeometryStorageService
            Dim objGeom As Object

            objGSS = CreateObject("Geomedia.GeometryStorageService")
            objGSS.GeometryToStorage(Geometry, objGeom)



            With objRS
                .AddNew()
                .GFields(GetGeometryFieldName(objRS)).Value = objGeom
                .Update()
            End With

            objGeom = Nothing
            objGSS = Nothing
            NewGeometry = True
            Exit Function
MyErr:
            MsgBox(Err.Description, MsgBoxStyle.Critical, "添加图素出错！")

            NewGeometry = False
            objGeom = Nothing
            objGSS = Nothing
        End Function

        Shared Function ReLoadGeoMetry(ByRef OcxMapView As AxMapviewLib.AxGMMapView) As Boolean
            Dim i, iGeometryType As Integer
            Dim objRLE As PView.RecordLegendEntry                 '''MapView数据对象集合
            Dim sGeometry As String                         '''图形数据字段名
            Dim objStyle As Object
            Dim strTitle As String

            Dim objLocatedObjects As New PView.LocatedObjectsCollection()
            Dim objSmartLocSvrc As New PBasic.SmartLocateService()
            Dim objRecord As Object
            Dim objPntGeom As PBasic.PointGeometry
            '''============================================================
            On Error GoTo ErrorHandle 'Resume Next
            '''============================================================
            'OcxMapView.MapViewSelectedObjects.Clear()
            'OcxMapView.HighlightedObjects.Clear()
            i = 0
            For Each objRLE In OcxMapView.Legend.LegendEntries
                i = i + 1
                objRLE.Recordset.MoveFirst()
                If (objRLE.Recordset.Name = rsGrecordset.Name) And _
                    (objRLE.Recordset.GFields(0).SourceDatabase = rsGrecordset.GFields(0).SourceDatabase) Then
                    objStyle = objRLE.Style
                    strTitle = objRLE.Title
                    sGeometry = GetGeometryFieldName(rsGrecordset)
                    OcxMapView.Legend.LegendEntries.Remove(i)
                    Exit For    '''删除操作执行完毕，退出循环
                End If
            Next objRLE
            '''============================================================
            objRLE = CreateObject("Geomedia.RecordLegendEntry")
            objRLE.GeometryFieldName = sGeometry
            objRLE.Recordset = rsGrecordset
            objRLE.Style = objStyle
            objRLE.Title = strTitle
            If OcxMapView.Legend.LegendEntries.Count = 0 Then
                OcxMapView.Legend.LegendEntries.Append(objRLE)
            Else
                OcxMapView.Legend.LegendEntries.Append(objRLE, 1)
            End If

            objRLE.LoadData()


            'objPntGeom = New PBasic.PointGeometry()
            'objPntGeom = GetCenterPoint(rsGrecordset)
            'objSmartLocSvrc.Locate(objPntGeom, OcxMapView.Dispatch, objLocatedObjects)
            'OcxMapView.MapViewSelectedObjects.Add(objLocatedObjects.Item(1))

            'OcxMapView.Legend.Fit()
            OcxMapView.CtlRefresh(False)
            '''============================================================
            objStyle = Nothing
            objRLE = Nothing
            '''============================================================
            ReLoadGeoMetry = True
            Exit Function
ErrorHandle:
            MsgBox(Err.Description, MsgBoxStyle.OKOnly, "重新加载图形时出错")
            ReLoadGeoMetry = False
            Exit Function
        End Function

        Shared Function PointOnline(ByVal pnt As PBasic.point, ByVal Geom As Object) As Integer
            On Error GoTo MyErr
            Dim i As Integer
            Dim j As Integer
            Dim pnt1 As New PBasic.point()
            Dim pnt2 As New PBasic.point()


            If Geom.Type = "CompositePolygonGeometry" Then
                If Geom.Count > 1 Then
                    GoTo MyErr
                Else
                    Geom = Geom.Item(1)
                End If
            End If

            For i = 1 To Geom.Points.Count
                pnt1 = Geom.Points(i)
                If i <> Geom.Points.Count Then
                    pnt2 = Geom.Points(i + 1)
                Else
                    pnt2 = Geom.Points(1)
                End If


                If vbCommon.PointOnSegment(pnt1, pnt2, pnt) Then
                    PointOnline = i
                    Exit Function
                End If
            Next
MyErr:
            PointOnline = -1
        End Function

        '计算两点之间的距离
        Shared Function GetDistanceBetweenTwoPoints(ByVal pntOrigin As PBasic.point, ByVal pntEnd As PBasic.point) As Double
            Dim dblPow2X, dblPow2Y As Double
            dblPow2X = System.Math.Pow(pntOrigin.X - pntEnd.X, 2)
            dblPow2Y = System.Math.Pow(pntOrigin.Y - pntEnd.Y, 2)
            GetDistanceBetweenTwoPoints = System.Math.Pow(dblPow2X + dblPow2Y, 1 / 2)
        End Function


        '为显示LOGO图形，定义的Style.
        Shared Function GetLogoStyleObject(ByRef iGeometryType As Short) As Object

            Dim objStyle As Object
            Dim objFont As New StdType.StdFont()

            On Error GoTo ErrorHandler

            Select Case iGeometryType
                Case PClient.GConstants.gdbPoint
                    objStyle = CreateObject("GeoMedia.SymbolFontStyle")
                    With objStyle
                        .Color = RGB(0, 255, 0)
                        .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaperAsNonscaling
                        .FontName = "WingDings"
                        .Index = Asc("A") '74
                        .Size = 800
                    End With

                Case PClient.GConstants.gdbGraphicsText
                    objStyle = CreateObject("GeoMedia.TextStyle")
                    With objStyle
                        .Color = RGB(0, 0, 0)
                        .Font = objFont
                        .Font.Name = "Arial"
                        .Font.Size = 8
                        .Font.Bold = True

                        .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaperAsNonscaling
                    End With


            End Select

            nNextColor = GetNextQBColor()
            GetLogoStyleObject = objStyle
            Exit Function

ErrorHandler:
            MsgBox(Err.Description, MSGBOX_ERROR, "GetStyleObject出错")
            objStyle = Nothing
            GetLogoStyleObject = Nothing

        End Function


        '图上高亮
        Shared Sub HighlightGeometry(ByVal strID As String, ByRef objRS As GDO.GRecordset, ByRef OcxMapView As AxMapviewLib.AxGMMapView)
            Dim objrecord As Object
            '清除现有的高亮和选中状态
            OcxMapView.HighlightedObjects.Clear()
            OcxMapView.MapViewSelectedObjects.Clear()
            '找到选中的记录，并添加为选中状态
            objRS.MoveFirst()
            While Not objRS.EOF
                If (objRS.GFields("ID").Value = strID) Then
                    objrecord = CreateObject("Geomedia.RecordObject")
                    objrecord.Recordset = objRS
                    objrecord.bookmark = objRS.Bookmark
                    OcxMapView.MapViewSelectedObjects.Add(objrecord)
                    Exit While
                End If
                objRS.MoveNext()
            End While
            OcxMapView.CtlRefresh(True)
        End Sub
    End Class
End Namespace