Sub ChangeRenderToUVRenderer()
On Error GoTo ERH
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pMap As IMap
Set pMap = pMxDoc.FocusMap
' Get raster input from layer
Dim pRLayer As IRasterLayer
Set pRLayer = pMap.Layer(0)
Dim pRaster As IRaster
Set pRaster = pRLayer.Raster
' Get the number of rows from raster table
Dim pTable As ITable
Dim pBand As IRasterBand
Dim pBandCol As IRasterBandCollection
Set pBandCol = pRaster
Set pBand = pBandCol.Item(0)
Dim TableExist As Boolean
pBand.HasTable TableExist
If Not TableExist Then Exit Sub
Set pTable = pBand.AttributeTable
Dim NumOfValues As Integer
NumOfValues = pTable.RowCount(Nothing)
' Specified a field and get the field index for the specified field to be rendered.
Dim FieldIndex As Integer
Dim FieldName As String
FieldName = "Value" ' Value is the default field, you can specify other field here
FieldIndex = pTable.FindField(FieldName)
' Create random color
Dim pRamp As IRandomColorRamp
Set pRamp = New RandomColorRamp
pRamp.Size = NumOfValues
pRamp.Seed = 100
pRamp.CreateRamp (True)
Dim pFSymbol As ISimpleFillSymbol
' Create UniqueValue renderer and QI RasterRenderer
Dim pUVRen As IRasterUniqueValueRenderer
Set pUVRen = New RasterUniqueValueRenderer
Dim pRasRen As IRasterRenderer
Set pRasRen = pUVRen
' Connect the renderer and the raster
Set pRasRen.Raster = pRaster
pRasRen.Update
' Set UniqueValue renerer
pUVRen.HeadingCount = 1 ' Use one heading
pUVRen.Heading(0) = "All Data Values"
pUVRen.ClassCount(0) = NumOfValues
pUVRen.Field = FieldName
Dim I As Long
Dim pRow As IRow
Dim LabelValue As Variant
For I = 0 To NumOfValues - 1
Set pRow = pTable.GetRow(I) 'Get a row from the table
LabelValue = pRow.Value(FieldIndex)
pUVRen.AddValue 0, I, LabelValue 'Get a row from the table
pUVRen.Label(0, I) = CStr(LabelValue) ' Set label
Set pFSymbol = New SimpleFillSymbol
pFSymbol.Color = pRamp.Color(I)
pUVRen.Symbol(0, I) = pFSymbol 'Set symbol
Next I
'Update render and refresh layer
pRasRen.Update
Set pRLayer.Renderer = pUVRen
pMxDoc.ActiveView.Refresh
pMxDoc.UpdateContents
' Clean up
Set pMxDoc = Nothing
Set pRLayer = Nothing
Set pUVRen = Nothing
Set pRasRen = Nothing
Set pRamp = Nothing
Set pFSymbol = Nothing
Set pRaster = Nothing
Set pRLayer = Nothing
Set pMap = Nothing
Set pBand = Nothing
Set pBandCol = Nothing
Set pTable = Nothing
Set pRow = Nothing
Exit Sub
ERH:
MsgBox Err.Description
End Sub
