geometryop.vb

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

                    objLE.Style = objStyle
                    objLE.Title = strTitle
                    DisplayTheLegendEntry(objLE, OcxMapView)
                Else
                    DisplayTheLegendEntry(objLE, OcxMapView)
                End If
            End If
            Exit Function
errhandle:
            MsgBox(Err.Description, MsgBoxStyle.OKOnly, "重新加载图例时出错")
        End Function

        Shared Function GetStyleObject(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")
                    objStyle.Color = QBColor(nNextColor)
                    objStyle.StyleUnits = PView.StyleConstants.gmsStyleUnitsPaperAsNonscaling
                    objStyle.FontName = "Wingdings"
                    objStyle.Index = 74
                    objStyle.Size = 50

                Case PClient.GConstants.gdbGraphicsText
                    objStyle = CreateObject("GeoMedia.TextStyle")
                    objStyle.Color = QBColor(nNextColor)
                    objStyle.Font = objFont
                    objStyle.Font.Name = "Arial"
                    objStyle.Font.Size = 10
                    objStyle.Font.Bold = True
                    objStyle.StyleUnits = PView.StyleConstants.gmsStyleUnitsPaperAsNonscaling



                Case PClient.GConstants.gdbAreal
                    objStyle = CreateObject("GeoMedia.AreaStyle")
                    objStyle.BoundaryOn = True
                    With objStyle.Boundary
                        .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaper
                        .Mode = PView.StyleConstants.gmsLinearModeShowBackground
                        .Color = QBColor(nNextColor)
                        .Width = 400
                        .BackStyle = PView.StyleConstants.gmsLinearMediumDashed
                    End With
                    nNextColor = GetNextQBColor()

                    With objStyle
                        .BackColor = PView.StyleTransparentConstant.gmsRGBTransparent
                        '.BackColor = QBColor(nNextColor)
                        .FillMode = PView.StyleConstants.gmsFillModeStandard
                        '.FillType = PView.StyleConstants.gmsFPDiagCrossHatch
                        '.ForeColor = QBColor(15)
                        .HatchSpacing = 10
                        .HatchWidth = 3
                        .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaper
                    End With


                Case PClient.GConstants.gdbAnySpatial
                    objStyle = CreateObject("GeoMedia.AnyStyle")
                    objStyle.TextStyle = CreateObject("GeoMedia.TextStyle")
                    With objStyle.TextStyle
                        .Color = QBColor(nNextColor)
                        .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaper
                        .Font = System.Windows.Forms.Control.DefaultFont.Clone()
                        With .Font
                            .Name = "Times New Roman"
                            .Size = 10
                        End With
                    End With
                    nNextColor = GetNextQBColor()

                    objStyle.PointStyle = CreateObject("GeoMedia.SymbolFontStyle")
                    With objStyle.PointStyle
                        .Color = QBColor(nNextColor)
                        .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaperAsNonscaling
                        .FontName = "Wingdings"
                        .Index = 100
                        .Size = 10
                    End With
                    nNextColor = GetNextQBColor()

                    objStyle.LinearStyle = CreateObject("GeoMedia.LinearStyle")
                    With objStyle.LinearStyle
                        .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaper
                        .Mode = PView.StyleConstants.gmsLinearModeShowBackground
                        .Color = QBColor(nNextColor)
                        .Width = 1
                        .BackStyle = PView.StyleConstants.gmsLinearMediumDashed
                    End With
                    nNextColor = GetNextQBColor()

                    objStyle.AreaStyle = CreateObject("GeoMedia.AreaStyle")
                    With objStyle.AreaStyle
                        .BoundaryOn = True
                        With .Boundary
                            .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaper
                            .Mode = PView.StyleConstants.gmsLinearModeShowBackground
                            .Color = QBColor(nNextColor)
                            .Width = 1
                            .BackStyle = PView.StyleConstants.gmsLinearMediumDashed
                        End With
                        nNextColor = GetNextQBColor()

                        .BackColor = QBColor(nNextColor)
                        .FillMode = PView.StyleConstants.gmsFillModeStandard
                        .FillType = PView.StyleConstants.gmsFPDiagCrossHatch
                        .ForeColor = QBColor(15)
                        .HatchSpacing = 10
                        .HatchWidth = 3
                        .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaper
                    End With

                Case PClient.GConstants.gdbLinear
                    objStyle = CreateObject("GeoMedia.LinearStyle")
                    objStyle.StyleUnits = PView.StyleConstants.gmsStyleUnitsPaper
                    objStyle.Mode = PView.StyleConstants.gmsLinearModeShowBackground
                    objStyle.Color = QBColor(nNextColor)
                    objStyle.Width = 1
                Case Else
                    objStyle = CreateObject("GeoMedia.LinearStyle")
                    objStyle.StyleUnits = PView.StyleConstants.gmsStyleUnitsPaper
                    objStyle.Mode = PView.StyleConstants.gmsLinearModeShowBackground
                    objStyle.Color = QBColor(nNextColor)
                    objStyle.Width = 1
            End Select

            nNextColor = GetNextQBColor()
            GetStyleObject = objStyle
            Exit Function

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

        End Function

        Shared Function GetNextQBColor() As Short

            If nNextColor > 14 Then
                GetNextQBColor = 0
            Else
                GetNextQBColor = nNextColor + 1
            End If

        End Function

        Shared Function SnapToGeometry(ByVal mapview As Object, ByVal objLocateCollection As PView.LocatedObjectsCollection, ByVal InputPoint As PBasic.point, ByRef retSnapPnt As PBasic.point, ByRef retSnapType As Integer, ByRef Retsnapindex As Short) As Boolean
            Dim snapSvr As PClient.SnapService
            Dim locobject As Object
            Dim geomfield As Object
            Dim GeomStoreSvr As Object
            Dim loctolerance As Double

            Dim x1 As Double
            Dim y1 As Double
            Dim z1 As Double
            Dim x2 As Double

            Dim snapType As Integer
            Dim snapDist As Double
            Dim snapGeom As Object
            Dim snapPoint As PBasic.point
            Dim parentGeom As Object
            Dim keyPointIndex As Integer
            Dim keyPointTotIndex As Integer

            Dim KeyPnt As PBasic.point
            Dim svKeyType As Integer

            Dim svKeyDist As Double
            Dim KeyDist As Double
            Dim KeyIndex As Short

            snapSvr = New PClient.SnapService()
            retSnapPnt = New PBasic.point()
            retSnapPnt.X = InputPoint.X
            retSnapPnt.Y = InputPoint.Y
            retSnapPnt.Z = InputPoint.Z

            SnapToGeometry = False
            mapview.WindowToWorld(CInt(0), CInt(0), x1, y1, z1)
            mapview.WindowToWorld(CInt(5), CInt(0), x2, y1, z1)
            loctolerance = System.Math.Abs(x2 - x1)
            snapSvr.SnapTolerance = loctolerance
            snapSvr.SnapTypes = PClient.EnableSnapTypeConstants.gmssSnapToEndPoint + PClient.EnableSnapTypeConstants.gmssSnapToVertex + PClient.EnableSnapTypeConstants.gmssSnapToElement

            For Each locobject In objLocateCollection
                If snapSvr.SnapToLocatedObject(locobject, InputPoint, parentGeom, snapGeom, snapPoint, snapType, snapDist, keyPointIndex, keyPointTotIndex) Then
                    KeyPnt = snapPoint
                    svKeyType = snapType
                    KeyIndex = keyPointIndex
                    KeyDist = snapDist
                    SnapToGeometry = True

                    retSnapPnt.X = KeyPnt.X
                    retSnapPnt.Y = KeyPnt.Y
                    retSnapPnt.Z = KeyPnt.Z
                    retSnapType = svKeyType
                    Retsnapindex = KeyIndex
                End If
            Next locobject
            locobject = Nothing
            snapSvr = Nothing
            geomfield = Nothing
        End Function

        Shared Function BlobToGeometry(ByRef Blob As Object) As Object
            On Error GoTo MyErr
            Dim objGss As New PClient.GeometryStorageService()
            Dim objGeometry As Object
            objGss.StorageToGeometry(Blob, objGeometry)
            BlobToGeometry = objGeometry
            objGss = Nothing
            objGeometry = Nothing
            Exit Function
MyErr:
            BlobToGeometry = Nothing
            MsgBox(Err.Description, MsgBoxStyle.OKOnly, "BlobToGeometry出错 ")
        End Function

        Shared Function GetGeometryFieldName(ByRef InputRecordset As GDO.GRecordset) As String
            On Error GoTo errhandle
            Dim objfield As GDO.GField
            For Each objfield In InputRecordset.GFields
                If objfield.Type = GDO.GConstants.gdbSpatial Or objfield.Type = GDO.GConstants.gdbGraphic Then
                    GetGeometryFieldName = objfield.Name
                    Exit For
                Else
                    GetGeometryFieldName = ""
                End If
            Next objfield
            objfield = Nothing
            Exit Function
errhandle:
            MsgBox("GetGeometryFieldName失败")
            objfield = Nothing
        End Function

        Shared Function GetGeometryType(ByVal InputRecordset As GDO.GRecordset) As Long
            On Error GoTo errhandle
            'Create the ExtendedPropertySet of the input recordset.
            Dim objExt As PClient.ExtendedPropertySet
            objExt = InputRecordset.GetExtension("ExtendedPropertySet")