mod_symbol.bas

ArcEngine 这是基于AE组件的源代码

    Set pDataStatistics = New DataStatistics
    Set pDataStatistics.Cursor = pCursor
    pDataStatistics.Field = strNameField
    
    Set pStatisticsResult = pDataStatistics.Statistics                                                '好像必须是数字集才不出错
    If pStatisticsResult Is Nothing Then
        MsgBox "Failed to gather stats on the feature class"
        Exit Sub
    End If
       
    Set pFillSymbol = New SimpleFillSymbol
    pFillSymbol.color = GetRGBColor(239, 228, 190) ' Tan
    
    Set pSimpleMarkerSymbol = New SimpleMarkerSymbol
    With pSimpleMarkerSymbol
        .Style = esriSMSSquare
        .color = GetRGBColor(255, 0, 0) ' Red
        .SIZE = 2
        .Outline = True
        .OutlineColor = GetRGBColor(0, 0, 0) ' Black
    End With
    
    Set pProportionalSymbolRenderer = New ProportionalSymbolRenderer
    With pProportionalSymbolRenderer
        .ValueUnit = esriUnknownUnits
        .Field = strNameField
        .FlanneryCompensation = False
        .MinDataValue = pStatisticsResult.Minimum
        .MaxDataValue = pStatisticsResult.Maximum
        .BackgroundSymbol = pFillSymbol
        .MinSymbol = pSimpleMarkerSymbol
    End With
    
Err:
    Set m_pGeoFeatureLayer.Renderer = pProportionalSymbolRenderer
    Set pProportionalSymbolRenderer = Nothing
    Set pTable = Nothing
    Set pCursor = Nothing
    Set pCursor = Nothing
    Set pFillSymbol = Nothing
    Set pSimpleMarkerSymbol = Nothing
    Set pColor = Nothing
    Set pOutlineColor = Nothing
    
    frmMDIMap.MapControl.refresh
    frmMDITocBar.TOCControl.Update

End Sub

Public Sub ClassBreaksSymbol(m_pGeoFeatureLayer As IGeoFeatureLayer, strNameField As String)
    Dim pTable As ITable
    Dim pClassify As IClassify
    Dim pTableHistogram As ITableHistogram
    Dim pHistogram As IHistogram
    Dim dataFrequency As Variant
    Dim dataValues As Variant
    Dim strOutput As String
   
    On Error GoTo Err
    Set pTable = m_pGeoFeatureLayer
    Set pTableHistogram = New TableHistogram
    Set pHistogram = pTableHistogram
    
    pTableHistogram.Field = strNameField
    Set pTableHistogram.Table = pTable
    pHistogram.GetHistogram dataValues, dataFrequency
    
    Set pClassify = New EqualInterval
    pClassify.SetHistogramData dataValues, dataFrequency
    
    Dim Classes() As Double
    Dim ClassesCount As Long
    
    pClassify.Classify 3 'numDesiredClasses
    Classes = pClassify.ClassBreaks
    ClassesCount = UBound(Classes)
    
    Dim pClassBreaksRenderer As IClassBreaksRenderer
    
    Set pClassBreaksRenderer = New ClassBreaksRenderer
    pClassBreaksRenderer.Field = strNameField
    pClassBreaksRenderer.BreakCount = ClassesCount
    pClassBreaksRenderer.SortClassesAscending = True
    
    Dim pFromColor As IHsvColor
    
    Set pFromColor = New HsvColor
    pFromColor.Hue = 60         ' Yellow
    pFromColor.Saturation = 100
    pFromColor.Value = 96
    
    Dim pToColor As IHsvColor
    
    Set pToColor = New HsvColor
    pToColor.Hue = 0         ' Red
    pToColor.Saturation = 100
    pToColor.Value = 96
    
    Dim pRamp As IAlgorithmicColorRamp
    Dim pEnumColors As IEnumColors
    Dim ok As Boolean
    
    Set pRamp = New AlgorithmicColorRamp
    pRamp.Algorithm = esriHSVAlgorithm
    pRamp.FromColor = pFromColor
    pRamp.ToColor = pToColor
    pRamp.SIZE = ClassesCount
    pRamp.CreateRamp ok
    Set pEnumColors = pRamp.Colors
   
    Dim pColor As IColor
    Dim pFillSymbol As ISimpleFillSymbol
    Dim breakIndex As Long
    
    For breakIndex = 0 To ClassesCount - 1
    
        Set pColor = pEnumColors.Next
        Set pFillSymbol = New SimpleFillSymbol
        pFillSymbol.color = pColor
        pFillSymbol.Style = esriSFSSolid
        pClassBreaksRenderer.Symbol(breakIndex) = pFillSymbol
        pClassBreaksRenderer.Break(breakIndex) = Classes(breakIndex + 1)
        
        strOutput = strOutput & "- " & Classes(breakIndex + 1) & vbNewLine
    
    Next breakIndex
   
    Set m_pGeoFeatureLayer.Renderer = pClassBreaksRenderer
    frmMDIMap.MapControl.refresh
    frmMDITocBar.TOCControl.Update
    
Err:
    Set pTable = Nothing
    Set pClassify = Nothing
    Set pTableHistogram = Nothing
    Set pHistogram = Nothing
End Sub

Public Sub BarChartSymbol(m_pGeoFeatureLayer As IGeoFeatureLayer, strPopField1 As String, strPopField2 As String)
    Dim pChartRenderer As IChartRenderer
    Dim pRendererFields As IRendererFields
    
    Set pChartRenderer = New ChartRenderer
    
    ' Set up the fields to draw charts of
    Set pRendererFields = pChartRenderer
    pRendererFields.AddField strPopField1
    pRendererFields.FieldAlias(0) = pRendererFields.Field(0)
    pRendererFields.AddField strPopField2
    pRendererFields.FieldAlias(1) = pRendererFields.Field(1)
    
    Dim pTable As ITable
    Dim pCursor As ICursor
    Dim pQueryFilter As IQueryFilter
    Dim pRow As IRowBuffer
    
    Set pTable = m_pGeoFeatureLayer
    Set pQueryFilter = New QueryFilter
    pQueryFilter.AddField strPopField1
    pQueryFilter.AddField strPopField2
    Set pCursor = pTable.Search(pQueryFilter, True)
    
    Const numFields As Long = 2 ' Number of bars
    Dim fieldIndecies(0 To numFields - 1) As Long
    Dim fieldIndex As Long
    Dim maxValue As Double
    Dim firstValue As Boolean
    Dim fieldValue As Double
    
    fieldIndecies(0) = pTable.FindField(strPopField1)
    fieldIndecies(1) = pTable.FindField(strPopField2)
    firstValue = True
    maxValue = 0
    
    ' Iterate across each feature
    Set pRow = pCursor.NextRow
    Do While Not pRow Is Nothing
       For fieldIndex = 0 To numFields - 1
            fieldValue = pRow.Value(fieldIndecies(fieldIndex))
            If firstValue Then
                ' Special case for the first value in a feature class
                maxValue = fieldValue
                firstValue = False
            Else
                If fieldValue > maxValue Then
                    ' we've got a new biggest value
                    maxValue = fieldValue
                End If
            End If
    
        Next fieldIndex
    
        Set pRow = pCursor.NextRow
    Loop
    
    If (maxValue <= 0) Then
        MsgBox "Failed to calculate the maximum value or max value is 0."
        Exit Sub
    End If
    
    ' Set up the chart marker symbol to use with the renderer
    Dim pBarChartSymbol As IBarChartSymbol
    Dim pFillSymbol As IFillSymbol
    Dim pMarkerSymbol As IMarkerSymbol
    Dim pSymbolArray As ISymbolArray
    Dim pChartSymbol As IChartSymbol
    
    Set pBarChartSymbol = New BarChartSymbol
    Set pChartSymbol = pBarChartSymbol
    pBarChartSymbol.Width = 6
    Set pMarkerSymbol = pBarChartSymbol
    
    ' Finally we've got the biggest value, set this into the symbol
    pChartSymbol.maxValue = maxValue
    
    ' This is the maximum height of the bars
    pMarkerSymbol.SIZE = 16
    
    ' Now set up symbols for each bar
    Set pSymbolArray = pBarChartSymbol
    
    ' Add some colours in for each bar
    
    Set pFillSymbol = New SimpleFillSymbol
    ' This is a pastel purple
    pFillSymbol.color = GetRGBColor(213, 212, 252)
    pSymbolArray.AddSymbol pFillSymbol
    
    Set pFillSymbol = New SimpleFillSymbol
    ' This is a pastel green
    pFillSymbol.color = GetRGBColor(193, 252, 179)
    pSymbolArray.AddSymbol pFillSymbol
    
    ' Now set the barchart symbol into the renderer
    Set pChartRenderer.ChartSymbol = pBarChartSymbol
    pChartRenderer.Label = "Population"
    
    ' set up the background symbol to use tan color
    Set pFillSymbol = New SimpleFillSymbol
    pFillSymbol.color = GetRGBColor(239, 228, 190)
    Set pChartRenderer.BaseSymbol = pFillSymbol
    
    ' Disable overpoaster so that charts appear in the centre of polygons
    pChartRenderer.UseOverposter = False
    
    ' Update the renderer and refresh the screen
    Set m_pGeoFeatureLayer.Renderer = pChartRenderer
    frmMDIMap.MapControl.refresh
    frmMDITocBar.TOCControl.Update
End Sub