mod_symbol.bas

arcengine+vb开发原码

    Set tempFeatureLayer = m_pCurrentLayer

    If (tempFeatureLayer.FeatureClass.ShapeType = esriGeometryPoint) Then
        Call PointSymbol(tempFeatureLayer, color)
    ElseIf (tempFeatureLayer.FeatureClass.ShapeType = esriGeometryPolyline) Then
        Call LineSymbol(tempFeatureLayer, color)
    ElseIf (tempFeatureLayer.FeatureClass.ShapeType = esriGeometryPolygon) Then
        Call PolygonSymbol(tempFeatureLayer, color)
    End If
    
    'frmTOC.TOCControl.Update
End Sub

'输入：red、green、blue的颜色号，取值在0-255之间
'输出：rgbcolor
'功能：根据颜色号获取irgbcolor
'时间：2005.1.30
'源人：tjh
'更新：
Private Function GetRGBColor(yourRed As Long, yourGreen As Long, yourBlue As Long) As IRgbColor
  Dim pRGB As IRgbColor
  
  Set pRGB = New RgbColor
  With pRGB
    .Red = yourRed
    .Green = yourGreen
    .Blue = yourBlue
    .UseWindowsDithering = True
  End With
  Set GetRGBColor = pRGB
 '需要释放pRGB吗？
End Function
Private Sub PointSymbol(ByVal currentLayer As IGeoFeatureLayer, ByVal color As Long)
    '控制点图层的简单符号
    Dim pMarkLayer As IGeoFeatureLayer
    Dim pSimpleRenderer As ISimpleRenderer
    Dim pSimpleMarkerSymbol As ISimpleMarkerSymbol
    Dim pRgbColor As IRgbColor
    
    Set pMarkLayer = currentLayer
    Set pSimpleRenderer = New SimpleRenderer
    Set pSimpleMarkerSymbol = New SimpleMarkerSymbol
    
    '////////待考虑
    Set pRgbColor = New RgbColor
    pRgbColor.RGB = color
   
    With pSimpleMarkerSymbol
        .color = pRgbColor
        .SIZE = 10
        .Style = esriSMSCircle
    End With
    '////////待考虑
    
    Set pSimpleRenderer.Symbol = pSimpleMarkerSymbol
    
    Set pMarkLayer.Renderer = pSimpleRenderer
    
    '可以提到窗体中实现 ?
    frmMapControl.arcMapControl.Refresh
    
    Set pRgbColor = Nothing
    Set pSimpleMarkerSymbol = Nothing
    Set pSimpleRenderer = Nothing
    Set pMarkLayer = Nothing
End Sub
Private Sub LineSymbol(ByVal currentLayer As IGeoFeatureLayer, ByVal color As Long)
    '控制线图层的简单符号
    Dim pLineLayer As IGeoFeatureLayer
    Dim pSimpleRenderer As ISimpleRenderer
    Dim pSimpleLineSymbol As ISimpleLineSymbol
    Dim pRgbColor As IRgbColor
    
    Set pLineLayer = currentLayer
    Set pSimpleRenderer = New SimpleRenderer
    Set pSimpleLineSymbol = New SimpleLineSymbol
    Set pRgbColor = New RgbColor
    pRgbColor.RGB = color
    
    '////////待考虑
    With pSimpleLineSymbol
        .color = pRgbColor
        .Width = 2
        .Style = esriSLSDashDotDot
    End With
    '////////待考虑
    
    Set pSimpleRenderer.Symbol = pSimpleLineSymbol
    
    Set pLineLayer.Renderer = pSimpleRenderer
    
    '可以提到窗体中实现 ?
    frmMapControl.arcMapControl.Refresh
    
    Set pRgbColor = Nothing
    Set pSimpleLineSymbol = Nothing
    Set pSimpleRenderer = Nothing
    Set pLineLayer = Nothing
End Sub

Private Sub PolygonSymbol(ByVal currentLayer As IGeoFeatureLayer, ByVal color As Long)
    '控制面图层的简单符号
    Dim pFillLayer As IGeoFeatureLayer
    Dim pSimpleRenderer As ISimpleRenderer
    Dim pSimpleFillSymbol As ISimpleFillSymbol
    Dim pRgbColor As IRgbColor
    
    Set pFillLayer = currentLayer
    Set pSimpleRenderer = New SimpleRenderer
    Set pSimpleFillSymbol = New SimpleFillSymbol
    Set pRgbColor = New RgbColor
    pRgbColor.RGB = color
    
    '////////待考虑
    With pSimpleFillSymbol
        .color = pRgbColor
        .Style = esriSFSDiagonalCross
    End With
    '////////待考虑
    
    Set pSimpleRenderer.Symbol = pSimpleFillSymbol
    Set pFillLayer.Renderer = pSimpleRenderer
    
    '可以提到窗体中实现 ?
    frmMapControl.arcMapControl.Refresh
    
    Set pRgbColor = Nothing
    Set pSimpleFillSymbol = Nothing
    Set pSimpleRenderer = Nothing
    Set pFillLayer = Nothing
End Sub

Public Sub UniqueValueSymbol(m_pGeoFeatureLayer As IGeoFeatureLayer, strNameField As String)
    Dim pUniqueValueRenderer As IUniqueValueRenderer
    Dim pSym As IFillSymbol
    Dim pColor As IColor
    Dim pNextUniqueColor As IColor
    Dim pEnumRamp As IEnumColors
    Dim pTable As ITable
    Dim fieldNumber As Long
    Dim pNextRow As IRow
    Dim pNextRowBuffer As IRowBuffer
    Dim pCursor As ICursor
    Dim pQueryFilter As IQueryFilter
    Dim codeValue As Variant

    Set pUniqueValueRenderer = New UniqueValueRenderer
    Set pTable = m_pGeoFeatureLayer
    fieldNumber = pTable.FindField(strNameField)
    If fieldNumber = -1 Then
        MsgBox "Can't find field called " & strNameField
    Exit Sub
    End If

    pUniqueValueRenderer.FieldCount = 1
    pUniqueValueRenderer.Field(0) = strNameField
    
    '//////为了通用，考虑将符号从外部传入
    Dim pColorRamp As IRandomColorRamp
    
    Set pColorRamp = New RandomColorRamp
    '可以根据需要设置RandomColorRamp的设置
    pColorRamp.StartHue = 0
    pColorRamp.MinValue = 99
    pColorRamp.MinSaturation = 15
    pColorRamp.EndHue = 360
    pColorRamp.maxValue = 100
    pColorRamp.MaxSaturation = 30
    pColorRamp.SIZE = 100
    pColorRamp.CreateRamp True
    Set pEnumRamp = pColorRamp.Colors
    Set pNextUniqueColor = Nothing
    
    Set pQueryFilter = New QueryFilter
    pQueryFilter.AddField strNameField
    Set pCursor = pTable.Search(pQueryFilter, True)
    Set pNextRow = pCursor.NextRow
    
    Do While Not pNextRow Is Nothing
        Set pNextRowBuffer = pNextRow
        codeValue = pNextRowBuffer.Value(fieldNumber)
        
        Set pNextUniqueColor = pEnumRamp.Next
        If pNextUniqueColor Is Nothing Then
            pEnumRamp.Reset
            Set pNextUniqueColor = pEnumRamp.Next
        End If
        Set pSym = New SimpleFillSymbol
        pSym.color = pNextUniqueColor
        
        '//////为了通用，考虑将符号从外部传入
        pUniqueValueRenderer.AddValue codeValue, codeValue, pSym
        
        Set pNextRow = pCursor.NextRow
    Loop

    Set m_pGeoFeatureLayer.Renderer = pUniqueValueRenderer
    Set pSym = Nothing
    Set pColor = Nothing
    Set pNextUniqueColor = Nothing
    Set pEnumRamp = Nothing
    Set pTable = Nothing
    Set pNextRow = Nothing
    Set pNextRowBuffer = Nothing
    Set pCursor = Nothing
    Set pQueryFilter = Nothing
    Set codeValue = Nothing
    
    '可以提到窗体中实现 ?
    frmMapControl.arcMapControl.Refresh
    frmMapControl.arcMapControl.Update
End Sub

Public Sub DotDensitySymbol(m_pGeoFeatureLayer As IGeoFeatureLayer, strNameField As String)
    Dim pDotDensityRenderer As IDotDensityRenderer
    Dim pDotDensityFillSymbol As IDotDensityFillSymbol
    Dim pRendererFields As IRendererFields
    Dim pSymbolArray As ISymbolArray
    
    Set pDotDensityRenderer = New DotDensityRenderer
    Set pRendererFields = pDotDensityRenderer
    pRendererFields.AddField strNameField
    
    Set pDotDensityFillSymbol = New DotDensityFillSymbol
    
    '可以增加DotDensityFillSymbol设置！！！
    pDotDensityFillSymbol.DotSize = 3
    pDotDensityFillSymbol.color = GetRGBColor(0, 0, 0)
    pDotDensityFillSymbol.backgroundColor = GetRGBColor(239, 228, 190) ' color of tan
    
    Dim pMarkerSymbol As ISimpleMarkerSymbol
    
    Set pSymbolArray = pDotDensityFillSymbol
    
    '可以增加DotDensityFillSymbol设置！！
    Set pMarkerSymbol = New SimpleMarkerSymbol
    pMarkerSymbol.Style = esriSMSCircle
    pMarkerSymbol.SIZE = 3
    pMarkerSymbol.color = GetRGBColor(0, 0, 0) ' Black
    pSymbolArray.AddSymbol pMarkerSymbol
    
    Set pDotDensityRenderer.DotDensitySymbol = pDotDensityFillSymbol
    
    pDotDensityRenderer.DotValue = 200000
    Set m_pGeoFeatureLayer.Renderer = pDotDensityRenderer
    
    Set pDotDensityRenderer = Nothing
    Set pDotDensityFillSymbol = Nothing
    Set pRendererFields = Nothing
    Set pSymbolArray = Nothing
    
    '可以提到窗体中实现 ?
    frmMapControl.arcMapControl.Refresh
    frmMapControl.arcMapControl.Update
End Sub

Public Sub PropSymbol(m_pGeoFeatureLayer As IGeoFeatureLayer, strNameField As String)
    Dim pProportionalSymbolRenderer As IProportionalSymbolRenderer
    Dim pTable As ITable
    Dim pQueryFilter As IQueryFilter
    Dim pCursor As ICursor
    Dim pFillSymbol As IFillSymbol
    Dim pSimpleMarkerSymbol As ISimpleMarkerSymbol
    Dim pColor As IColor
    Dim pOutlineColor As IColor
    
    On Error GoTo Err
    Set pTable = m_pGeoFeatureLayer
    Set pQueryFilter = New QueryFilter
    pQueryFilter.AddField strNameField
    Set pCursor = pTable.Search(pQueryFilter, True)
    
    Dim pDataStatistics As IDataStatistics
    Dim pStatisticsResult As IStatisticsResults
    
    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
    
    '可以提到窗体中实现 ?
    frmMapControl.arcMapControl.Refresh
    frmMapControl.arcMapControl.Update

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
    
    '可以提到窗体中实现 ?
    frmMapControl.arcMapControl.Refresh
    frmMapControl.arcMapControl.Update
End Sub