Mod_Symbol.bas

作者:独木舟日期:2009-02-21

字体大小: 小中大

view plain copy to clipboard print ?

Attribute VB_Name = "ModSymbol"
Option Explicit
'功能：符号预览
Public Const COLORONCOLOR = 3
Public Const HORZSIZE = 4
Public Const VERTSIZE = 6
Public Const HORZRES = 8
Public Const VERTRES = 10
Public Const ASPECTX = 40
Public Const ASPECTY = 42
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Type PicDesc
SIZE As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type SIZE
X As Long
Y As Long
End Type
Public Type POINTAPI
X As Long
Y As Long
End Type
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (pDesc As PicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, pPic As IPicture) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function FillRect Lib "USER32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetWindowExtEx Lib "gdi32" (ByVal hdc As Long, lpSize As SIZE) As Long
Public Declare Function GetViewportExtEx Lib "gdi32" (ByVal hdc As Long, lpSize As SIZE) As Long
Public Declare Function GetMapMode Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function LPtoDP Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Public Declare Function GetClientRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Function SaveSymbolToBitmapFile(ByVal hDCOld As Long, ByVal pSymbol As ISymbol, ByVal lWidth As Long, ByVal lHeight As Long, ByVal sFilePath As String, Optional lGap As Long = 0) As Boolean
On Error GoTo errH
SaveSymbolToBitmapFile = False
Dim pPicture As IPicture, hBmpNew As Long
Set pPicture = CreatePictureFromSymbol(hDCOld, hBmpNew, pSymbol, lWidth, lHeight, lGap)
If Not pPicture Is Nothing Then
SavePicture pPicture, sFilePath
DeleteObject hBmpNew
SaveSymbolToBitmapFile = True
End If
Exit Function
errH:
If Err.Number <> 0 Then
Dim sError As String, lError As Long
sError = Err.Description
lError = Err.Number
Err.Clear
Err.Raise vbObjectError + 7020, "basDrawSymbol.SaveSymbolToBitmapFile", "Error occured while saving to bitmap file." & vbNewLine & "Error " & CStr(lError) & sError
End If
End Function
Public Function CreatePictureFromSymbol(ByVal hDCOld As Long, ByRef hBmpNew As Long, ByVal pSymbol As ISymbol, ByVal lWidth As Long, ByVal lHeight As Long, Optional lGap As Long = 0) As IPictureDisp
On Error GoTo errH
Dim hDCNew As Long, hBmpOld As Long
hDCNew = CreateCompatibleDC(hDCOld)
hBmpNew = CreateCompatibleBitmap(hDCOld, lWidth, lHeight)
hBmpOld = SelectObject(hDCNew, hBmpNew)
Dim lResult As Long
lResult = DrawToDC(hDCNew, lWidth, lHeight, pSymbol, lGap)
hBmpNew = SelectObject(hDCNew, hBmpOld)
DeleteDC hDCNew
Set CreatePictureFromSymbol = CreatePictureFromBitmap(hBmpNew)
Exit Function
errH:
If Err.Number <> 0 Then
If Not pSymbol Is Nothing Then
pSymbol.ResetDC
If hBmpNew <> 0 And hDCNew <> 0 And hBmpOld <> 0 Then
hBmpNew = SelectObject(hDCNew, hBmpOld)
DeleteDC hDCNew
End If
End If
End If
End Function
Private Function CreatePictureFromBitmap(ByVal hBmpNew As OLE_HANDLE) As IPictureDisp
Dim pic As PicDesc
Dim pPic As IPicture
Dim IID_IDispatch As GUID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With pic
.SIZE = Len(pic)
.Type = vbPicTypeBitmap
.hBmp = hBmpNew
.hPal = 0
End With
Dim Result As Long
Result = OleCreatePictureIndirect(pic, IID_IDispatch, True, pPic)
Debug.Print "Result OLE call: " & Result
Set CreatePictureFromBitmap = pPic
End Function
Public Function DrawToWnd(ByVal hWnd As OLE_HANDLE, ByVal pSymbol As ISymbol, Optional lGap As Long = 0) As Boolean
On Error GoTo errH
DrawToWnd = False
Dim hdc As OLE_HANDLE
If hWnd <> 0 Then
Dim udtRect As RECT, lResult As Long
lResult = GetClientRect(hWnd, udtRect)
If lResult <> 0 Then
Dim lWidth As Long, lHeight As Long
lWidth = udtRect.Right - udtRect.Left
lHeight = udtRect.Bottom - udtRect.Top
hdc = GetDC(hWnd)
If hdc <> 0 Then
DrawToWnd = DrawToDC(hdc, lWidth, lHeight, pSymbol, lGap)
End If
ReleaseDC hWnd, hdc
End If
End If
Exit Function
errH:
If Err.Number <> 0 Then
If Not pSymbol Is Nothing Then
pSymbol.ResetDC
End If
If hWnd <> 0 And hdc <> 0 Then
ReleaseDC hWnd, hdc
End If
Exit Function
End If
End Function
Public Function DrawToDC(ByVal hdc As OLE_HANDLE, lWidth As Long, lHeight As Long, ByVal pSymbol As ISymbol, Optional lGap As Long = 0) As Boolean
On Error GoTo errH
DrawToDC = False
If hdc <> 0 Then
If Not Clear(hdc, &HFFFFFF, 0, 0, lWidth, lHeight) Then
Err.Raise vbObjectError + 7002, "basDrawSymbol.DrawToDC", "Could not clear the Device Context."
Exit Function
End If
Dim pEnvelope As IEnvelope, pTransformation As ITransformation, pGeom As IGeometry
Set pEnvelope = New Envelope
pEnvelope.PutCoords lGap, lGap, lWidth - lGap, lHeight - lGap
Set pTransformation = CreateTransFromDC(hdc, lWidth, lHeight)
Set pGeom = CreateSymShape(pSymbol, pEnvelope)
If Not pTransformation Is Nothing And Not pGeom Is Nothing Then
pSymbol.SetupDC hdc, pTransformation
pSymbol.Draw pGeom
pSymbol.ResetDC
DrawToDC = True
Else
Err.Raise vbObjectError + 7008, "basDrawSymbol.DrawToDC", "Could not create required Transformation or Geometry for this draw operation."
End If
End If
Exit Function
errH:
If Err.Number <> 0 Then
If Not pSymbol Is Nothing Then
pSymbol.ResetDC
End If
End If
End Function
Private Function Clear(ByVal hdc As Long, ByVal backgroundColor As Long, ByVal xMin As Long, ByVal yMin As Long, ByVal xMax As Long, ByVal yMax As Long) As Boolean
On Error GoTo errH
Dim hBrushBackground As Long, udtBounds As RECT, lResult As Long
With udtBounds
.Left = xMin
.Top = yMin
.Right = xMax
.Bottom = yMax
End With
hBrushBackground = CreateSolidBrush(backgroundColor)
If hBrushBackground = 0 Then
Err.Raise vbObjectError + 7003, "basDrawSymbol.Clear", "Could not create GDI Brush."
Exit Function
End If
lResult = FillRect(hdc, udtBounds, hBrushBackground)
If hBrushBackground = 0 Then
Err.Raise vbObjectError + 7004, "basDrawSymbol.Clear", "Could not fill Device Context."
End If
lResult = DeleteObject(hBrushBackground)
If hBrushBackground = 0 Then
Err.Raise vbObjectError + 7005, "basDrawSymbol.Clear", "Could not delete GDI Brush."
End If
Clear = True
Exit Function
errH:
If Err.Number <> 0 Then
Clear = False
If hBrushBackground <> 0 Then
lResult = DeleteObject(hBrushBackground)
End If
End If
End Function
Private Function CreateTransFromDC(ByVal hdc As Long, ByVal lWidth As Long, ByVal lHeight As Long) As ITransformation
On Error GoTo errH
Dim pBoundsEnvelope As IEnvelope
Set pBoundsEnvelope = New Envelope
pBoundsEnvelope.PutCoords 0, 0, lWidth, lHeight
Dim deviceRect As tagRECT
With deviceRect
.Left = 0
.Top = 0
.Right = lWidth
.Bottom = lHeight
End With
Dim dpi As Long
dpi = GetDeviceCaps(hdc, LOGPIXELSY)
If dpi = 0 Then
Err.Raise vbObjectError + 7006, "basDrawSymbol.CreateTransFromDC", "Could not retrieve Resolution from device context."
Exit Function
End If
Dim pDisplayTransformation As IDisplayTransformation
Set CreateTransFromDC = New DisplayTransformation
Set pDisplayTransformation = CreateTransFromDC
With pDisplayTransformation
.VisibleBounds = pBoundsEnvelope
.Bounds = pBoundsEnvelope
.DeviceFrame = deviceRect
.Resolution = dpi
End With
Exit Function
errH:
If Err.Number <> 0 Then
Set CreateTransFromDC = Nothing
End If
End Function
Private Function CreateSymShape(ByVal pSymbol As ISymbol, ByVal pEnvelope As IEnvelope) As IGeometry
On Error GoTo errH
If TypeOf pSymbol Is IMarkerSymbol Then
Dim pArea As IArea
Set pArea = pEnvelope
Set CreateSymShape = pArea.Centroid
ElseIf TypeOf pSymbol Is ILineSymbol or TypeOf pSymbol Is ITextSymbol Then
Dim pPolyline As IPolyline
Set pPolyline = New Polyline
pPolyline.FromPoint = pEnvelope.LowerLeft
pPolyline.ToPoint = pEnvelope.UpperRight
Set CreateSymShape = pPolyline
Else
Set CreateSymShape = pEnvelope
End If
Exit Function
errH:
If Err.Number <> 0 Then
Set CreateSymShape = Nothing
End If
End Function
Public Function GetLayerSymbols(pLayer As ILayer) As IArray
If pLayer Is Nothing Then Exit Function
Dim i As Integer
Dim pGeoFeatureLayer As IGeoFeatureLayer
Set pGeoFeatureLayer = pLayer
If pGeoFeatureLayer Is Nothing Then Exit Function
Dim pMySymbolArray As ISymbolArray
Dim pSymbolArray As IArray
Set pSymbolArray = New esriSystem.Array
Debug.Assert Not pSymbolArray Is Nothing
If pSymbolArray Is Nothing Then Exit Function
'简单渲染图层
If TypeOf pGeoFeatureLayer.Renderer Is ISimpleRenderer Then
Dim pSimpleRender As ISimpleRenderer
Set pSimpleRender = pGeoFeatureLayer.Renderer
pSymbolArray.Add pSimpleRender.Symbol
End If
'单值渲染图层
If TypeOf pGeoFeatureLayer.Renderer Is IUniqueValueRenderer Then
Dim pUniqueValueRenderer As IUniqueValueRenderer
Set pUniqueValueRenderer = pGeoFeatureLayer.Renderer
Dim pSymbol As ISymbol
Set pSymbol = pUniqueValueRenderer.Symbol(CStr(pUniqueValueRenderer.Value(0)))
pSymbolArray.Add pSymbol
End If
'分类渲染图层
If TypeOf pGeoFeatureLayer.Renderer Is IClassBreaksRenderer Then
Dim pClassRenderer As IClassBreaksRenderer
Set pClassRenderer = pGeoFeatureLayer.Renderer
For i = 0 To pClassRenderer.BreakCount - 1
pSymbolArray.Add pClassRenderer.Symbol(i)
Next i
End If
'图表渲染图层
If TypeOf pGeoFeatureLayer.Renderer Is IChartRenderer Then
Dim pChartRenderer As IChartRenderer
Set pChartRenderer = pGeoFeatureLayer.Renderer
Dim pChartSymbol As IChartSymbol
Set pChartSymbol = pChartRenderer.ChartSymbol
Set pMySymbolArray = pChartSymbol
Debug.Assert Not pMySymbolArray Is Nothing
If pMySymbolArray Is Nothing Then Exit Function
For i = 0 To pMySymbolArray.SymbolCount - 1
pSymbolArray.Add pMySymbolArray.Symbol(i)
Next i
Debug.Assert Not pSymbolArray.Count < 1
End If
'点密度渲染图层(???)
If TypeOf pGeoFeatureLayer.Renderer Is IDotDensityRenderer Then
Dim pDotDensityRenderer As IDotDensityRenderer
Set pDotDensityRenderer = pGeoFeatureLayer.Renderer
Dim pDotDensityFillSymbol As IDotDensityFillSymbol
Set pDotDensityFillSymbol = pDotDensityRenderer.DotDensitySymbol
Set pMySymbolArray = pDotDensityFillSymbol
For i = 0 To pMySymbolArray.SymbolCount - 1
pSymbolArray.Add pMySymbolArray.Symbol(i)
Next i
End If
If Not pSymbolArray.Count < 1 Then Set GetLayerSymbols = pSymbolArray
Set pSymbolArray = Nothing
End Function
Public Function GetCurrentValueRanges(pLayer As ILayer) As Collection
If pLayer Is Nothing Then Exit Function
Dim pGeoFeatureLayer As IGeoFeatureLayer
Set pGeoFeatureLayer = pLayer
If pGeoFeatureLayer Is Nothing Then Exit Function
Dim colValueRanges As Collection
Set colValueRanges = New Collection
Debug.Assert Not colValueRanges Is Nothing
If colValueRanges Is Nothing Then Exit Function
'分类渲染图层
If TypeOf pGeoFeatureLayer.Renderer Is IClassBreaksRenderer Then
Dim pClassRenderer As IClassBreaksRenderer
Set pClassRenderer = pGeoFeatureLayer.Renderer
colValueRanges.Add "0" & "--" & pClassRenderer.Break(0)
Dim i As Integer
For i = 0 To pClassRenderer.BreakCount - 2
colValueRanges.Add pClassRenderer.Break(i) & "-" & pClassRenderer.Break(i + 1)
Next i
End If
If Not colValueRanges.Count < 1 Then Set GetCurrentValueRanges = colValueRanges
Set colValueRanges = Nothing
End Function
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
'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

Attribute VB_Name = "ModSymbol" 
Option Explicit 
'功能：符号预览 
 
Public Const COLORONCOLOR = 3 
 
Public Const HORZSIZE = 4 
Public Const VERTSIZE = 6 
Public Const HORZRES = 8 
Public Const VERTRES = 10 
Public Const ASPECTX = 40 
Public Const ASPECTY = 42 
Public Const LOGPIXELSX = 88 
Public Const LOGPIXELSY = 90 
 
Public Type GUID 
  Data1 As Long 
  Data2 As Integer 
  Data3 As Integer 
  Data4(7) As Byte 
End Type 
 
Public Type PicDesc 
  SIZE As Long 
  Type As Long 
  hBmp As Long 
  hPal As Long 
  Reserved As Long 
End Type 
 
Public Type RECT 
  Left As Long 
  Top As Long 
  Right As Long 
  Bottom As Long 
End Type 
 
Public Type SIZE 
  X As Long 
  Y As Long 
End Type 
 
Public Type POINTAPI 
  X As Long 
  Y As Long 
End Type 
 
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (pDesc As PicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, pPic As IPicture) As Long 
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long 
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long 
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long 
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long 
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long 
Public Declare Function FillRect Lib "USER32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long 
Public Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long 
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long 
Public Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long 
Public Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hdc As Long) As Long 
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long 
 
Public Declare Function GetWindowExtEx Lib "gdi32" (ByVal hdc As Long, lpSize As SIZE) As Long 
Public Declare Function GetViewportExtEx Lib "gdi32" (ByVal hdc As Long, lpSize As SIZE) As Long 
Public Declare Function GetMapMode Lib "gdi32" (ByVal hdc As Long) As Long 
Public Declare Function LPtoDP Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long 
Public Declare Function GetClientRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long 
 
Public Function SaveSymbolToBitmapFile(ByVal hDCOld As Long, ByVal pSymbol As ISymbol, ByVal lWidth As Long, ByVal lHeight As Long, ByVal sFilePath As String, Optional lGap As Long = 0) As Boolean 
 
  On Error GoTo errH 
     
  SaveSymbolToBitmapFile = False 
     
  Dim pPicture As IPicture, hBmpNew As Long 
  Set pPicture = CreatePictureFromSymbol(hDCOld, hBmpNew, pSymbol, lWidth, lHeight, lGap) 
  If Not pPicture Is Nothing Then 
    SavePicture pPicture, sFilePath 
    DeleteObject hBmpNew 
    SaveSymbolToBitmapFile = True 
  End If 
   
Exit Function 
errH: 
  If Err.Number <> 0 Then 
    Dim sError As String, lError As Long 
    sError = Err.Description 
    lError = Err.Number 
    Err.Clear 
    Err.Raise vbObjectError + 7020, "basDrawSymbol.SaveSymbolToBitmapFile", "Error occured while saving to bitmap file." & vbNewLine & "Error " & CStr(lError) & sError 
  End If 
End Function 
 
Public Function CreatePictureFromSymbol(ByVal hDCOld As Long, ByRef hBmpNew As Long, ByVal pSymbol As ISymbol, ByVal lWidth As Long, ByVal lHeight As Long, Optional lGap As Long = 0) As IPictureDisp 
  On Error GoTo errH 
   
  Dim hDCNew As Long, hBmpOld As Long 
  hDCNew = CreateCompatibleDC(hDCOld) 
  hBmpNew = CreateCompatibleBitmap(hDCOld, lWidth, lHeight) 
  hBmpOld = SelectObject(hDCNew, hBmpNew) 
   
  Dim lResult As Long 
  lResult = DrawToDC(hDCNew, lWidth, lHeight, pSymbol, lGap) 
   
  hBmpNew = SelectObject(hDCNew, hBmpOld) 
  DeleteDC hDCNew 
 
  Set CreatePictureFromSymbol = CreatePictureFromBitmap(hBmpNew) 
 
Exit Function 
errH: 
  If Err.Number <> 0 Then 
    If Not pSymbol Is Nothing Then 
      pSymbol.ResetDC 
      If hBmpNew <> 0 And hDCNew <> 0 And hBmpOld <> 0 Then 
        hBmpNew = SelectObject(hDCNew, hBmpOld) 
        DeleteDC hDCNew 
      End If 
    End If 
  End If 
End Function 
 
Private Function CreatePictureFromBitmap(ByVal hBmpNew As OLE_HANDLE) As IPictureDisp 
  Dim pic As PicDesc 
  Dim pPic As IPicture 
  Dim IID_IDispatch As GUID 
 
  With IID_IDispatch 
     .Data1 = &H20400 
     .Data4(0) = &HC0 
     .Data4(7) = &H46 
  End With 
 
  With pic 
     .SIZE = Len(pic) 
     .Type = vbPicTypeBitmap 
     .hBmp = hBmpNew 
     .hPal = 0 
  End With 
 
  Dim Result As Long 
  Result = OleCreatePictureIndirect(pic, IID_IDispatch, True, pPic) 
  Debug.Print "Result OLE call: " & Result 
   
  Set CreatePictureFromBitmap = pPic 
End Function 
 
Public Function DrawToWnd(ByVal hWnd As OLE_HANDLE, ByVal pSymbol As ISymbol, Optional lGap As Long = 0) As Boolean 
  On Error GoTo errH 
   
  DrawToWnd = False 
   
  Dim hdc As OLE_HANDLE 
  If hWnd <> 0 Then 
            
    Dim udtRect As RECT, lResult  As Long 
    lResult = GetClientRect(hWnd, udtRect) 
     
    If lResult <> 0 Then 
      Dim lWidth As Long, lHeight As Long 
      lWidth = udtRect.Right - udtRect.Left 
      lHeight = udtRect.Bottom - udtRect.Top 
       
      hdc = GetDC(hWnd) 
      If hdc <> 0 Then 
        DrawToWnd = DrawToDC(hdc, lWidth, lHeight, pSymbol, lGap) 
      End If 
      ReleaseDC hWnd, hdc 
    End If 
  End If 
 
Exit Function 
errH: 
  If Err.Number <> 0 Then 
    If Not pSymbol Is Nothing Then 
      pSymbol.ResetDC 
    End If 
    If hWnd <> 0 And hdc <> 0 Then 
      ReleaseDC hWnd, hdc 
    End If 
    Exit Function 
  End If 
End Function 
 
Public Function DrawToDC(ByVal hdc As OLE_HANDLE, lWidth As Long, lHeight As Long, ByVal pSymbol As ISymbol, Optional lGap As Long = 0) As Boolean 
  On Error GoTo errH 
   
  DrawToDC = False 
   
  If hdc <> 0 Then 
   
    If Not Clear(hdc, &HFFFFFF, 0, 0, lWidth, lHeight) Then 
      Err.Raise vbObjectError + 7002, "basDrawSymbol.DrawToDC", "Could not clear the Device Context." 
      Exit Function 
    End If 
             
    Dim pEnvelope As IEnvelope, pTransformation As ITransformation, pGeom As IGeometry 
    Set pEnvelope = New Envelope 
    pEnvelope.PutCoords lGap, lGap, lWidth - lGap, lHeight - lGap 
    Set pTransformation = CreateTransFromDC(hdc, lWidth, lHeight) 
    Set pGeom = CreateSymShape(pSymbol, pEnvelope) 
     
    If Not pTransformation Is Nothing And Not pGeom Is Nothing Then 
      pSymbol.SetupDC hdc, pTransformation 
      pSymbol.Draw pGeom 
      pSymbol.ResetDC 
      DrawToDC = True 
    Else 
      Err.Raise vbObjectError + 7008, "basDrawSymbol.DrawToDC", "Could not create required Transformation or Geometry for this draw operation." 
    End If 
  End If 
 
Exit Function 
errH: 
  If Err.Number <> 0 Then 
    If Not pSymbol Is Nothing Then 
      pSymbol.ResetDC 
    End If 
  End If 
End Function 
 
Private Function Clear(ByVal hdc As Long, ByVal backgroundColor As Long, ByVal xMin As Long, ByVal yMin As Long, ByVal xMax As Long, ByVal yMax As Long) As Boolean 
   
  On Error GoTo errH 
   
  Dim hBrushBackground As Long, udtBounds As RECT, lResult  As Long 
  With udtBounds 
    .Left = xMin 
    .Top = yMin 
    .Right = xMax 
    .Bottom = yMax 
  End With 
   
  hBrushBackground = CreateSolidBrush(backgroundColor) 
  If hBrushBackground = 0 Then 
    Err.Raise vbObjectError + 7003, "basDrawSymbol.Clear", "Could not create GDI Brush." 
    Exit Function 
  End If 
   
  lResult = FillRect(hdc, udtBounds, hBrushBackground) 
  If hBrushBackground = 0 Then 
    Err.Raise vbObjectError + 7004, "basDrawSymbol.Clear", "Could not fill Device Context." 
  End If 
     
  lResult = DeleteObject(hBrushBackground) 
  If hBrushBackground = 0 Then 
    Err.Raise vbObjectError + 7005, "basDrawSymbol.Clear", "Could not delete GDI Brush." 
  End If 
   
  Clear = True 
   
Exit Function 
errH: 
  If Err.Number <> 0 Then 
    Clear = False 
    If hBrushBackground <> 0 Then 
      lResult = DeleteObject(hBrushBackground) 
    End If 
  End If 
End Function 
 
Private Function CreateTransFromDC(ByVal hdc As Long, ByVal lWidth As Long, ByVal lHeight As Long) As ITransformation 
   
  On Error GoTo errH 
   
  Dim pBoundsEnvelope As IEnvelope 
  Set pBoundsEnvelope = New Envelope 
  pBoundsEnvelope.PutCoords 0, 0, lWidth, lHeight 
   
  Dim deviceRect As tagRECT 
  With deviceRect 
    .Left = 0 
    .Top = 0 
    .Right = lWidth 
    .Bottom = lHeight 
  End With 
   
  Dim dpi As Long 
  dpi = GetDeviceCaps(hdc, LOGPIXELSY) 
  If dpi = 0 Then 
    Err.Raise vbObjectError + 7006, "basDrawSymbol.CreateTransFromDC", "Could not retrieve Resolution from device context." 
    Exit Function 
  End If 
   
  Dim pDisplayTransformation As IDisplayTransformation 
  Set CreateTransFromDC = New DisplayTransformation 
  Set pDisplayTransformation = CreateTransFromDC 
  With pDisplayTransformation 
    .VisibleBounds = pBoundsEnvelope 
    .Bounds = pBoundsEnvelope 
    .DeviceFrame = deviceRect 
    .Resolution = dpi 
  End With 
 
Exit Function 
errH: 
  If Err.Number <> 0 Then 
    Set CreateTransFromDC = Nothing 
  End If 
End Function 
 
Private Function CreateSymShape(ByVal pSymbol As ISymbol, ByVal pEnvelope As IEnvelope) As IGeometry 
   
  On Error GoTo errH 
   
  If TypeOf pSymbol Is IMarkerSymbol Then 
    Dim pArea As IArea 
    Set pArea = pEnvelope 
    Set CreateSymShape = pArea.Centroid 
  ElseIf TypeOf pSymbol Is ILineSymbol or TypeOf pSymbol Is ITextSymbol Then 
    Dim pPolyline As IPolyline 
    Set pPolyline = New Polyline 
    pPolyline.FromPoint = pEnvelope.LowerLeft 
    pPolyline.ToPoint = pEnvelope.UpperRight 
    Set CreateSymShape = pPolyline 
  Else 
    Set CreateSymShape = pEnvelope 
  End If 
   
Exit Function 
errH: 
  If Err.Number <> 0 Then 
    Set CreateSymShape = Nothing 
  End If 
End Function 
 
Public Function GetLayerSymbols(pLayer As ILayer) As IArray 
 
    If pLayer Is Nothing Then Exit Function 
     
    Dim i As Integer 
             
    Dim pGeoFeatureLayer As IGeoFeatureLayer 
    Set pGeoFeatureLayer = pLayer 
    If pGeoFeatureLayer Is Nothing Then Exit Function 
    Dim pMySymbolArray  As ISymbolArray 
     
    Dim pSymbolArray As IArray 
    Set pSymbolArray = New esriSystem.Array 
    Debug.Assert Not pSymbolArray Is Nothing 
    If pSymbolArray Is Nothing Then Exit Function 
     
    '简单渲染图层 
    If TypeOf pGeoFeatureLayer.Renderer Is ISimpleRenderer Then 
        Dim pSimpleRender As ISimpleRenderer 
        Set pSimpleRender = pGeoFeatureLayer.Renderer 
        pSymbolArray.Add pSimpleRender.Symbol 
    End If 
     
    '单值渲染图层 
    If TypeOf pGeoFeatureLayer.Renderer Is IUniqueValueRenderer Then 
     
        Dim pUniqueValueRenderer As IUniqueValueRenderer 
        Set pUniqueValueRenderer = pGeoFeatureLayer.Renderer 
        Dim pSymbol As ISymbol 
        Set pSymbol = pUniqueValueRenderer.Symbol(CStr(pUniqueValueRenderer.Value(0))) 
        pSymbolArray.Add pSymbol 
     
    End If 
     
    '分类渲染图层 
    If TypeOf pGeoFeatureLayer.Renderer Is IClassBreaksRenderer Then 
     
        Dim pClassRenderer As IClassBreaksRenderer 
        Set pClassRenderer = pGeoFeatureLayer.Renderer 
         
        For i = 0 To pClassRenderer.BreakCount - 1 
            pSymbolArray.Add pClassRenderer.Symbol(i) 
        Next i 
         
    End If 
     
    '图表渲染图层 
    If TypeOf pGeoFeatureLayer.Renderer Is IChartRenderer Then 
         
        Dim pChartRenderer As IChartRenderer 
        Set pChartRenderer = pGeoFeatureLayer.Renderer 
        Dim pChartSymbol As IChartSymbol 
        Set pChartSymbol = pChartRenderer.ChartSymbol 
             
        Set pMySymbolArray = pChartSymbol 
        Debug.Assert Not pMySymbolArray Is Nothing 
        If pMySymbolArray Is Nothing Then Exit Function 
         
        For i = 0 To pMySymbolArray.SymbolCount - 1 
            pSymbolArray.Add pMySymbolArray.Symbol(i) 
        Next i 
         
        Debug.Assert Not pSymbolArray.Count < 1 
     
    End If 
     
    '点密度渲染图层(???) 
    If TypeOf pGeoFeatureLayer.Renderer Is IDotDensityRenderer Then 
     
        Dim pDotDensityRenderer As IDotDensityRenderer 
        Set pDotDensityRenderer = pGeoFeatureLayer.Renderer 
        Dim pDotDensityFillSymbol As IDotDensityFillSymbol 
        Set pDotDensityFillSymbol = pDotDensityRenderer.DotDensitySymbol 
         
        Set pMySymbolArray = pDotDensityFillSymbol 
         
        For i = 0 To pMySymbolArray.SymbolCount - 1 
            pSymbolArray.Add pMySymbolArray.Symbol(i) 
        Next i 
     
    End If 
     
    If Not pSymbolArray.Count < 1 Then Set GetLayerSymbols = pSymbolArray 
    Set pSymbolArray = Nothing 
     
End Function 
 
Public Function GetCurrentValueRanges(pLayer As ILayer) As Collection 
 
    If pLayer Is Nothing Then Exit Function 
     
    Dim pGeoFeatureLayer As IGeoFeatureLayer 
    Set pGeoFeatureLayer = pLayer 
    If pGeoFeatureLayer Is Nothing Then Exit Function 
     
    Dim colValueRanges As Collection 
    Set colValueRanges = New Collection 
    Debug.Assert Not colValueRanges Is Nothing 
    If colValueRanges Is Nothing Then Exit Function 
     
    '分类渲染图层 
    If TypeOf pGeoFeatureLayer.Renderer Is IClassBreaksRenderer Then 
     
        Dim pClassRenderer As IClassBreaksRenderer 
        Set pClassRenderer = pGeoFeatureLayer.Renderer 
         
        colValueRanges.Add "0" & "--" & pClassRenderer.Break(0) 
         
        Dim i As Integer 
        For i = 0 To pClassRenderer.BreakCount - 2 
            colValueRanges.Add pClassRenderer.Break(i) & "-" & pClassRenderer.Break(i + 1) 
        Next i 
         
    End If 
     
    If Not colValueRanges.Count < 1 Then Set GetCurrentValueRanges = colValueRanges 
    Set colValueRanges = Nothing 
     
End Function 
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 
     
    '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

摘自http://www.pudn.com/downloads119/sourcecode/windows/csharp/detail504683.html

[本日志由独木舟于 2009-02-21 09:33 PM 编辑]

文章来自: 本站原创

引用通告: 查看所有引用 | 我要引用此文章

Tags: GIS Code

相关日志:

评论: 0 | 引用: 0 | 查看次数: -

发表评论

昵　称:
密　码:	游客发言不需要密码.
内　容:	正在加载编辑器...
验证码:
选　项:	禁止表情转换禁止自动转换链接禁止自动转换关键字

虽然发表评论不用注册，但是为了保护您的发言权，建议您注册帐号.

Mod_Symbol.bas

作者:独木舟日期:2009-02-21

User Panel

Statistics

Recent Comments

Archive

Search

Links

Mod_Symbol.bas

作者:独木舟 日期:2009-02-21

User Panel

Statistics

Recent Comments

Archive

Search

Links

作者:独木舟日期:2009-02-21