?? mod_symbol.bas
字號:
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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -