thematics.vb

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

        Dim Colors() As Integer
        Dim ColorNum As Integer

        Dim DB As GDO.GDatabase
        Dim RS As GDO.GRecordset
        Dim SQLtext As String

        If rbRange.Checked Then '按范围进行分色显示
            clsNum = CInt(tbRangeNum.Value)

        Else  '按属性值进行显示
 
            SQLtext = " Select  distinct  " + cblAttribute.Text + " from " + cblFeature.Text

            RS = gobjConnection.Database.OpenRecordset(SQLtext, 2) 'gdbOpenDynaset

            RS.MoveFirst()
            RS.MoveLast()

            clsNum = RS.RecordCount

            If clsNum > 255 Then
                MsgBox("该属性的值多于255个，不能按属性值进行分色。", MsgBoxStyle.Exclamation, "提示")
                btnOkay.Enabled = False
                Exit Sub

            End If

            RS = Nothing
        End If


        objColors = CreateObject("Geomedia.ColorSchemes")
        objColor = CreateObject("Geomedia.ColorScheme")
        objColor1 = CreateObject("Geomedia.ColorScheme")
        objColor2 = CreateObject("Geomedia.ColorScheme")
        objColor3 = CreateObject("Geomedia.ColorScheme")

        '随机色
        ReDim Colors(clsNum - 1)
        Randomize()

        For ColorNum = 0 To clsNum - 1
            Colors(ColorNum) = 16777215 * Rnd()
        Next ColorNum


        With objColor
            .Colors = Colors
            .Name = "1.随机色"
            .Type = 1 'gmcsRandom
        End With
        objColors.Append(objColor)

        '渐进红色
        For ColorNum = 0 To clsNum - 1
            iColor = 255 - CInt(255 / clsNum) * ColorNum
            Colors(ColorNum) = RGB(255, iColor, iColor)
        Next ColorNum

        With objColor1
            .Colors = Colors
            .Name = "2.渐进红色"
            .Type = 2 'gmcsRamp 
        End With
        objColors.Append(objColor1)

        '渐进绿色
        For ColorNum = 0 To clsNum - 1
            iColor = 255 - CInt(255 / clsNum) * ColorNum
            Colors(ColorNum) = RGB(iColor, 255, iColor)
        Next ColorNum

        With objColor2
            .Colors = Colors
            .Name = "3.渐进绿色"
        End With
        objColors.Append(objColor2)

        '渐进蓝色
        For ColorNum = 0 To clsNum - 1
            iColor = 255 - CInt(255 / clsNum) * ColorNum
            Colors(ColorNum) = RGB(iColor, iColor, 255)
        Next ColorNum

        With objColor3
            .Colors = Colors
            .Name = "4.渐进蓝色"
        End With
        objColors.Append(objColor3)

        objColor = Nothing
        objColor1 = Nothing
        objColor2 = Nothing
        objColor3 = Nothing



        '添加进入listbox,供选择
        cboColorSchemes.Items.Clear()
        For Each objColor In objColors
            cboColorSchemes.Items.Add(objColor.Name)
            If cboColorSchemes.Text = "" Then cboColorSchemes.Text = objColor.Name

        Next

        '使能确定键
        btnOkay.Enabled = True

        Exit Sub

ErrHander:
        MsgBox(Err.Description, MsgBoxStyle.Critical, "错误")

    End Sub


    Protected Overrides Sub Finalize()
        MyBase.Finalize()
    End Sub

    Private Sub FrmThematics_Closing(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing
        System.Runtime.InteropServices.Marshal.ReleaseComObject(objColors)
        objColors = Nothing

    End Sub

    Private Sub rbValue_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs)
        cblAttribute_SelectedIndexChanged(Nothing, Nothing)
        tbRangeNum.Enabled = False
    End Sub


    Private Sub rbRange_CheckedChanged(ByVal sender As System.Object, ByVal e As System.EventArgs)
        tbRangeNum.Enabled = True
    End Sub

    Private Sub btnOkay_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnOkay.Click
        '----------------------------------------------------------------------------------------------------------
        ' 根据选择的配色依据和方案，将专题图加入到图例里
        ' Intergraph Shenzhen 2005.1
        '----------------------------------------------------------------------------------------------------------

        '生成结果集
        On Error GoTo ErrHander

        Dim objRS As GDO.GRecordset
        Dim objOP As PClient.OriginatingPipe


        gobjConnection.CreateOriginatingPipe(objOP)
        objOP.Table = cblFeature.Text
        objRS = objOP.OutputRecordset
        objOP = Nothing


        '加入到图例里
        Dim objRLE As Object

        If rbRange.Checked Then
            objRLE = CreateObject("Geomedia.RangeLegendEntry")
        Else
            objRLE = CreateObject("Geomedia.UniqueValueLegendEntry")
        End If


        '根据选择的分色方式来确定图例显示
        objRLE.ColorSchemes = objColors
        objRLE.ColorSchemeIndex = CInt(cboColorSchemes.Text.Substring(0, 1))

        Dim iGeometryType As Integer
        Dim objExt As Object
        Dim objStyle As PView.SymbolFontStyle

        '定义图例参数
        With objRLE
            .GeometryFieldName = "Geometry"
            .Recordset = objRS

            objExt = objRS.GetExtension("ExtendedPropertySet")
            iGeometryType = objExt.GetValue("GeometryType")
            objExt = Nothing


            '根据不同的要素类型，来确定Style
            Select Case iGeometryType
                Case GDO.GConstants.gdbPoint
                    objStyle = CreateObject("Geomedia.SymbolFontStyle")
                    With objStyle
                        .AspectRatio = 1.25
                        .Color = RGB(128, 0, 64)
                        .FontName = "WingDings"
                        .index = Asc("B")
                        .Size = 25
                        .StyleUnits = PView.StyleConstants.gmsStyleUnitsPaper
                    End With
                    .Style = objStyle
                    objStyle = Nothing
                Case GDO.GConstants.gdbAreal
                    .Style = New PView.AreaStyle()
                Case GDO.GConstants.gdbLinear
                    .Style = New PView.LinearStyle()
                Case GDO.GConstants.gdbAnySpatial
                    .Style = New PView.AnyStyle()
            End Select

            .Ascending = True
            .ContentsMode = PAdvLgd.AdvancedLegendsConstants.gmalContentsModeDescription
            .Collapsed = False
            .Locatable = True
            .AttributeFieldName = cblAttribute.Text
            .Visible = True
            .Selected = False

            If rbRange.Checked Then
                .StatisticsMode = PAdvLgd.AdvancedLegendsConstants.gmalStatisticsModeRange
                .SetRanges(PAdvLgd.AdvancedLegendsConstants.gmalRangeByEqualCount, clsNum)

                '定义图例上的范围文字显示
                Dim objRange As PAdvLgd.Range

                For Each objRange In objRLE.Ranges
                    objRange.Description = objRange.RangeMinimum & " to " _
                           & objRange.RangeMaximum
                    objRange.Include = True
                Next
                objRange = Nothing

            Else
                .SetValues(PAdvLgd.AdvancedLegendsConstants.gmalUniqueValueByFieldValues)

            End If




            Dim objFont As New StdType.StdFont()
            With objFont
                .Name = "Arial"
                .Size = 10
                .Bold = True
            End With

            objRLE.TitleFont = objFont
            objRLE.TitleFontColor = RGB(0, 0, 100)
            objRLE.Title = cblFeature.Text


            With objFont
                .Name = "Arial"
                .Size = 8
                .Italic = True
            End With

            objRLE.SubtitleFont = objFont
            objRLE.SubtitleFontColor = RGB(0, 0, 200)
            objRLE.Subtitle = "by " + cblAttribute.Text

            With objFont
                .Name = "Arial"
                .Size = 7
                .Italic = True
            End With

            objRLE.HeadingFont = objFont
            objRLE.HeadingFontColor = RGB(0, 100, 100)
            objFont = Nothing

            If objRLE.ValidateSource Then
                If objMapView.Legend.LegendEntries.Count = 0 Then
                    objMapView.Legend.LegendEntries.Append(objRLE)
                Else
                    objMapView.Legend.LegendEntries.Append(objRLE, 1)
                End If
                objRLE.LoadData()
            End If

        End With

        objMapView.Legend.Fit()
        objMapView.Legend.Visible = True
        objMapView.Fit()
        objMapView.Refresh()

        Me.Close()



        Exit Sub
ErrHander:
        MsgBox(Err.Description)

    End Sub


    Private Sub tbRangeNum_Leave(ByVal sender As Object, ByVal e As System.EventArgs) Handles tbRangeNum.Leave
        SetColorSchemes()

    End Sub

  End Class