displayrenderers.frm

AO开发六种专题图的代码[独立执行程序]

  pMarkerSymbol.Size = 3
  pMarkerSymbol.Color = GetRGBColor(0, 0, 0) ' Black
  pSymbolArray.AddSymbol pMarkerSymbol
  
  Set pDotDensityRenderer.DotDensitySymbol = pDotDensityFillSymbol
  
  ' This relates to the number of dots per polygon,
  ' this value works for the US population
  pDotDensityRenderer.DotValue = 200000
  
  ' Update the renderer and refresh the screen
  Set m_pGeoFeatureLayer.Renderer = pDotDensityRenderer
  
  MapControl1.Refresh esriViewGeography

  txbOutput.Text = "Dot Density Renderer" & vbNewLine & vbNewLine & _
  "A dot density fill symbol and dot density renderer are used to depict population from field " & strPopField1 & "." & vbNewLine & _
  "Each dot represents a value of " & Format$(pDotDensityRenderer.DotValue, "###,###,###") & "."

End Sub

Private Sub cmdFullExtent_Click()

  ' Set the active views current extent to be the full extent of all layers
  '
  MapControl1.Extent = MapControl1.FullExtent
  
End Sub

Private Sub cmdLoadData_Click()

  ' Load in the shape file
  '
  ' Location of the folder and file containing the US states shape file
  ' Access it relative to the location of the sample
  '
  Dim strShapeFileFolder As String
  Dim strFilename As String
  strShapeFileFolder = App.Path & "\..\..\..\..\Data\Usa"
  strFilename = "states"

  Me.MousePointer = vbHourglass
  addShapeFileLayer strShapeFileFolder, strFilename, MapControl1
  Me.MousePointer = vbNormal
  
  ' If it successfully loaded then enable command buttons and initialise the
  ' layer form variable
  '
  If MapControl1.LayerCount > 0 Then
    Set m_pGeoFeatureLayer = MapControl1.Layer(0)
        
    ' Just make sure the shape file has the required fields
    ' if any of the fields return -1 then they're not in the shape file
    Dim pTable As ITable
    
    Set pTable = m_pGeoFeatureLayer
    
    If pTable.FindField(strNameField) = -1 Or _
      pTable.FindField(strPopField1) = -1 Or _
      pTable.FindField(strPopField2) = -1 Then
      
      MsgBox "Shape file " & strFilename & " does not have required fields (" _
       & strNameField & "," & strPopField1 & "," & strPopField2 & _
       ") for this sample."
       
      End
      
    End If
    
    
    MapControl1.MousePointer = esriPointerZoomIn
    
    cmdSimpleRenderer.Enabled = True
    cmdUniqueValue.Enabled = True
    cmdClassBreaks.Enabled = True
    cmdPropSymbol.Enabled = True
    cmdBarChart.Enabled = True
    cmdDotDensity.Enabled = True
    
    cmdLoadData.Enabled = False
  Else
    MsgBox "Failed to load shape file in folder " & strShapeFileFolder & " with filename " & strFilename
    End
  End If
End Sub

'
' Draw a point symbol on each state. The size of the point symbol relates to the
' size of the population of the state.
'
Private Sub cmdPropSymbol_Click()

  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

  ' QI the feature layer for the table interface
  '
  Set pTable = m_pGeoFeatureLayer

  ' Initialise a query and get a cursor to the first row
  '
  Set pQueryFilter = New QueryFilter
  pQueryFilter.AddField strPopField1
  Set pCursor = pTable.Search(pQueryFilter, True)

  ' Use the statistics objects to calculate the max value
  Dim pDataStatistics As IDataStatistics
  Dim pStatisticsResult As IStatisticsResults
  
  Set pDataStatistics = New DataStatistics
  Set pDataStatistics.Cursor = pCursor
  pDataStatistics.Field = strPopField1
  
  Set pStatisticsResult = pDataStatistics.Statistics
  If pStatisticsResult Is Nothing Then
    MsgBox "Failed to gather stats on the feature class"
    Exit Sub
  End If
   
  
  ' Set up the background fill color
  '
  Set pFillSymbol = New SimpleFillSymbol
  pFillSymbol.Color = GetRGBColor(239, 228, 190) ' Tan
  
  ' Set up the min symbol to a red square with a black outline for the proportional
  ' symbols
  '
  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
  
  ' Create a new proportional symbol renderer to draw population,
  ' the radius of the symbol reflects the size of the population.
  '
  Set pProportionalSymbolRenderer = New ProportionalSymbolRenderer
  With pProportionalSymbolRenderer
    .ValueUnit = esriUnknownUnits
    .Field = strPopField1
    .FlanneryCompensation = False
    .MinDataValue = pStatisticsResult.Minimum
    .MaxDataValue = pStatisticsResult.Maximum
    .BackgroundSymbol = pFillSymbol
    .MinSymbol = pSimpleMarkerSymbol
  End With

  ' Set the States layers renderer to the proportional symbol renderer and
  ' refresh the display
  '
  Set m_pGeoFeatureLayer.Renderer = pProportionalSymbolRenderer
  
  MapControl1.Refresh esriViewGeography

  Dim strMin As String
  Dim strMax As String
  
  strMin = Format$(pStatisticsResult.Minimum, "###,###,###")
  strMax = Format$(pStatisticsResult.Minimum, "###,###,###")
  
  txbOutput.Text = "Proportional Symbol Renderer" & vbNewLine & vbNewLine & _
  "Draws symbols in proportion to the values in field " & strPopField1 & "." & vbNewLine & _
  "This involved gathering some statistics on this field to calculate the min (" & strMin & ") and max (" & strMax & ") values."

End Sub


'
' Adds a shape file layer to a Map, given a workspace (folder)
' and featureClass name (filename)
'
Public Sub addShapeFileLayer(workspacePath As String, featureClassName As String, pControl As esriMapControl.MapControl)

  Dim pWorkspaceFactory As IWorkspaceFactory
  Dim pFeatureWorkSpace As IFeatureWorkspace
  Dim pFeatureClass As IFeatureClass
  Dim pGeoFeatureLayer As IGeoFeatureLayer

  On Error GoTo errorHandler:
  
  ' Create a factory object to generate workspace objects, then call the factory
  ' with the supplied folder spec.
  '
  Set pWorkspaceFactory = New ShapefileWorkspaceFactory
  Set pFeatureWorkSpace = pWorkspaceFactory.OpenFromFile(workspacePath, hWnd)
  If pFeatureWorkSpace Is Nothing Then Exit Sub
  
  ' We now have a valid workspace, now open a shape file (a type of featureClass)
  ' within this workspace folder
  '
  Set pFeatureClass = pFeatureWorkSpace.OpenFeatureClass(featureClassName)
  If pFeatureClass Is Nothing Then Exit Sub

  ' Define a layer object based on the feature class
  '
  Set pGeoFeatureLayer = New FeatureLayer
  pGeoFeatureLayer.Name = pFeatureClass.AliasName
  Set pGeoFeatureLayer.FeatureClass = pFeatureClass
  
  ' Now add the layer to the map and refresh the activeView to display the layer
  '
  pControl.AddLayer pGeoFeatureLayer
  
  ' Trap any errors trying to load the layer,
  ' the calling routine will handle this failure and report to the user
errorHandler:
  '
  Exit Sub
End Sub
'
' Set up a fill symbol with an outline and assign this to a new
' simple renderer object. Then assign this to the layer to ensures it draws with
' this symbology
'
Private Sub cmdSimpleRenderer_Click()

  Dim pGeoFeatureLayer As IGeoFeatureLayer
  Dim pSimpleRenderer As ISimpleRenderer
  Dim pFillSymbol As IFillSymbol
  Dim pOutlineSymbol As ILineSymbol

  Set pFillSymbol = New SimpleFillSymbol
  
  ' Initialise a color object to Lilac
  pFillSymbol.Color = GetRGBColor(235, 202, 250)
  
  ' Now initialise the line symbol used for the outline, set it to black
  ' and make it width of 1 point.
  ' Assign this into the fill symbols outline propetry.
  '
  Set pOutlineSymbol = New SimpleLineSymbol
  pOutlineSymbol.Color = GetRGBColor(0, 0, 0)
  pOutlineSymbol.Width = 1
  pFillSymbol.Outline = pOutlineSymbol

  ' Now initialise the simple renderer and assign it a fill symbol,
  ' by default it doesn't have a symbol
  '
  Set pSimpleRenderer = New SimpleRenderer
  Set pSimpleRenderer.Symbol = pFillSymbol
  
  ' Now set the layers renderer property to be this simple renderer,
  ' and refresh the screen
  '
  Set m_pGeoFeatureLayer.Renderer = pSimpleRenderer

  MapControl1.Refresh esriViewGeography
      
  ' Output some information
  txbOutput.Text = "Simple Renderer" & vbNewLine & vbNewLine & _
    "Fills polygons with a uniform fill color" & "." & vbNewLine & _
    "Fill color is lilac and has RGB value of " & pFillSymbol.Color.RGB & "."
      
End Sub
'
' This sets the renderer to display a different color for each state
'
Private Sub cmdUniqueValue_Click()

  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

  ' Iterate through the class and a random color ramp
  ' retrieve a state name, and a corresponding random color. Put the name and
  ' color into the unique value renderer. When complete assign the renderer to the
  ' layer and refresh to display the symbology.

  ' Create a color ramp, color object and a unique value renderer to be set up
  ' later on
  '
  Set pUniqueValueRenderer = New UniqueValueRenderer
  
  ' QI the table from the geoFeatureLayer and get the field number of
  '
  Set pTable = m_pGeoFeatureLayer
  fieldNumber = pTable.FindField(strNameField)
  If fieldNumber = -1 Then
    MsgBox "Can't find field called " & strNameField
    Exit Sub
  End If
  
  ' Specify the fied to renderer unique values with
  '
  pUniqueValueRenderer.FieldCount = 1
  pUniqueValueRenderer.Field(0) = strNameField
  
  ' Set up the Color ramp, this came from looking at ArcMaps Color Ramp
  ' properties for Pastels.
  '
  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
   
  ' Get a enumerator on the first row of the Layer
  '
  Set pQueryFilter = New QueryFilter
  pQueryFilter.AddField strNameField
  Set pCursor = pTable.Search(pQueryFilter, True)
  Set pNextRow = pCursor.NextRow
 
  
  ' Iterate through each row, adding values and a color to the unique value renderer
  ' Note we don't bother filtering out duplicates,
  ' if we add in a second value that is already there
  ' the symbol changes but the value remains
  '
  Do While Not pNextRow Is Nothing

    ' QI the row buffer from the row and get the value
    '
    Set pNextRowBuffer = pNextRow
    codeValue = pNextRowBuffer.Value(fieldNumber)

    ' Get a Color object from the color ramp and advance the enumerator
    ' if we've run out then reset and start again
    '
    Set pNextUniqueColor = pEnumRamp.Next
    If pNextUniqueColor Is Nothing Then
      pEnumRamp.Reset
      Set pNextUniqueColor = pEnumRamp.Next
    End If

    ' Set the symbol to the Color and add it to render a given value
    '
    Set pSym = New SimpleFillSymbol
    pSym.Color = pNextUniqueColor
    pUniqueValueRenderer.AddValue codeValue, codeValue, pSym

    ' Advance the cursor to the next row, or end of the dataset
    '
    Set pNextRow = pCursor.NextRow

  Loop
  
  ' Now set the layers renderer to the unique value renderer
  '
  Set m_pGeoFeatureLayer.Renderer = pUniqueValueRenderer
  
  MapControl1.Refresh esriViewGeography
      
  ' Output some information
  txbOutput.Text = "Unique Value Renderer" & vbNewLine & vbNewLine & _
    "Fills polygons with a different color for each unique value in the field " & strNameField & "." & vbNewLine & _
    "The number of unique values is " & pUniqueValueRenderer.ValueCount & "." & vbNewLine & _
    "The colors are generated from a random colour ramp based on pastels."
    
     
End Sub


'
' Initialialises the application
'
Private Sub Form_Load()

  ' Intialise the command button states
  '
  cmdSimpleRenderer.Enabled = False
  cmdUniqueValue.Enabled = False
  cmdClassBreaks.Enabled = False
  cmdPropSymbol.Enabled = False
  cmdBarChart.Enabled = False
  cmdDotDensity.Enabled = False
  cmdLoadData.Enabled = True

  
End Sub

'
' This implements a zoom In on the map control
'
Private Sub MapControl1_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long, ByVal mapX As Double, ByVal mapY As Double)
  
  MapControl1.Extent = MapControl1.TrackRectangle
  
End Sub
'
' This function returns an RGB colour object initialised with the supplied Red Green and Blue values.
' All parameters range from 0 to 255 in value
'
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