mod_symbol.bas

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

Attribute VB_Name = "Mod_Symbol"
Option Explicit

Public Sub FeatuerSymbol(ByVal color As Long)
    Dim tempFeatureLayer As IGeoFeatureLayer
    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
    
    frmMDITocBar.TOCControl.Update
'    MsgBox tempFeatureLayer.FeatureClass.ShapeType & "  " & tempFeatureLayer.Name
End Sub
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

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
    
    frmMDIMap.MapControl.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
    
    frmMDIMap.MapControl.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
    
    frmMDIMap.MapControl.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
    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
    
    frmMDIMap.MapControl.refresh
    frmMDITocBar.TOCControl.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
    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
    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
    
    frmMDIMap.MapControl.refresh
    frmMDITocBar.TOCControl.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