Canvec/NTDB Symbology arcmap 9.3 vba macro

'********************************************
'This Module is part of the Sofware Enhancement for Emergency Mapping (SEEM) Project
'this Module is used to generate a symbology that fits a field in the data and the name of a style galery item
'As to be in ArcMap to use not in a stand alone vb6 application but as a vba macro
'********************************************


Option Explicit

Dim m_pGeoFLayer As Variant     'modular variable use to pass on the feature layer
Dim m_pMxDoc As IMxDocument     'modular variable, active document
Dim m_pMap As IMap              'modular variable, active Map


Public Sub MapSymbology()
'*** this is the start of the program. The goal is to change the symbology to fit with the style gallery


Dim strMes As String    ' use for debug with mesagebox
Dim i As Integer        ' simple counter

' get the document

Set m_pMxDoc = ThisDocument

' get the map

Set m_pMap = m_pMxDoc.FocusMap


' get the layers in the map
Dim pLayer As ILayer
Dim pstrLayerName As String


' cycle through each layer to change Symbology
For i = 0 To m_pMap.LayerCount - 1

    'layer in this map
    Set pLayer = m_pMap.Layer(i)
    pstrLayerName = pLayer.Name
    'MsgBox (" layer name = " & pstrLayerName)



    If TypeOf pLayer Is IFeatureLayer Then
        'feature layer
        Dim pFLayer As IFeatureLayer2
        Set pFLayer = pLayer            'QI not really use here but always usefull
'MsgBox ("shapetype of layer" & pFLayer.ShapeType)
        'Dim pGeoFLayer As IGeoFeatureLayer
        If TypeOf pLayer Is IGeoFeatureLayer Then
         Set m_pGeoFLayer = pLayer
        End If

        ApplyUniqueRenderer (m_pGeoFLayer)
        'If frmSymbology.Tag = "Error" Then Exit Sub

     End If
Next i

'Update and refresh the view to see changes
m_pMxDoc.UpdateContents
m_pMxDoc.ActiveView.Refresh


End Sub

Private Sub ApplyUniqueRenderer(SomeLayer As IGeoFeatureLayer)

'*****************************************************
'   this sub generate the uniquevaluerenderer to use
'   need a featurelayer as intrant
'******************************************************

' Create and initiate renderer
Dim pUVRenderer As IUniqueValueRenderer
Set pUVRenderer = New UniqueValueRenderer
Dim strField As String
strField = frmSymbology.txtFieldName

pUVRenderer.FieldCount = 1   'set how many field for to use to symbolize
pUVRenderer.Field(0) = strField 'name of the field to use


Dim pFLayer As IFeatureLayer
Dim pFClass As IFeatureClass
Set pFLayer = SomeLayer     'QI
Set pFClass = pFLayer.FeatureClass

'Need a cursor to cycle the featureclass

Dim pFCursor As IFeatureCursor
Set pFCursor = pFClass.Search(Nothing, True)

Dim pFeature As IFeature
Dim pSym As IUnknown            ' IUnknown because it can be a point, line or fill symbol
Dim pSymDefault As IUnknown     ' IUnknown because it can be a point, line or fill symbol

'get the first element
Set pFeature = pFCursor.NextFeature

Dim strValue As String

'Dinamic array to get all possible element values

Dim MyArray() As String
Dim i As Integer        'counter
Dim j As Integer        'counter
Dim lngField As Long
i = 0

Dim bolFound As Boolean

ReDim MyArray(0)        'dimention the array to 1 element

Dim strSymCategory As String  ' use to get the category of element

'Loop to all feature
Do Until pFeature Is Nothing
strSymCategory = ""

lngField = pFClass.FindField(strField)

If lngField = -1 Then
    MsgBox "field not found!!"
    'frmSymbology.Tag = "Error"
    Exit Sub

Else
    strValue = pFeature.Value(pFClass.FindField(strField)) ' get the value of the field ATC for this element (row)
'    If strValue = "0" Then
'        strValue = "Generic/Default"
'    End If
    If Not strValue = "" Or Not strValue = " " Then
        If MyArray(0) = "" Then
            MyArray(i) = strValue
            i = i + 1
            ReDim Preserve MyArray(i)  'make space to received a other value
        Else
            For j = 0 To i - 1
                If MyArray(j) = strValue Then
                    bolFound = True     ' value is already in the array
                    Exit For
                Else
                    bolFound = False    ' value is not in this array(j)
                End If
            Next j
            If Not bolFound Then
                MyArray(i) = strValue
                i = i + 1
                ReDim Preserve MyArray(i) 'make space to received a other value
            End If
        End If
    End If

    Set pFeature = pFCursor.NextFeature   ' go to the next feature
End If
Loop

'get the default value
 Select Case pFClass.ShapeType
    Case 1  'point
     Set pSymDefault = GetStyleItem("Marker Symbols", "Default", strSymCategory)    '** Get the Default Symbol for Marker

    Case 3  'Line
     Set pSymDefault = GetStyleItem("Line Symbols", "Default", strSymCategory)      '** Get the Default Symbol for Line

    Case 4  'Polygon
     Set pSymDefault = GetStyleItem("Fill Symbols", "Default", strSymCategory)      '** Get the Default Symbol for Fill

    End Select
If frmSymbology.Tag = "Error" Then Exit Sub

' find the corresponding symbol for each element present in the array
For j = 0 To UBound(MyArray) - 1
  '** Choose the right group of Shape (point, line, fill)
    If Not MyArray(j) = "0" Then

        Select Case pFClass.ShapeType
            Case 1  'point
                Set pSym = GetStyleItem("Marker Symbols", MyArray(j), strSymCategory)           '** Get the Symbol
              '**************** go to the angle field and see if the angle is -1 or not, that tell us is we have to apply a angle to the symbology

                Dim pFCursor2 As IFeatureCursor
                Set pFCursor2 = pFClass.Search(Nothing, True)
                Dim pFeature2 As IFeature
                Set pFeature2 = pFCursor2.NextFeature

                Dim pBolAngle As Boolean
                Dim numValue As Integer
                Dim intLoop As Integer
                pBolAngle = False
                lngField = pFClass.FindField("ANGLE")
                If Not lngField = -1 Then

                    numValue = pFeature2.Value(pFClass.FindField("ANGLE")) ' get the value of the field ANGLE for this element (row)

                    If Not numValue = -1 Then
                        pBolAngle = True
                    End If
                End If

            Case 3  'Line
                Set pSym = GetStyleItem("Line Symbols", MyArray(j), strSymCategory)              '** Get the Symbol

            Case 4  'Polygon
                 Set pSym = GetStyleItem("Fill Symbols", MyArray(j), strSymCategory)              '** Get the Symbol
        End Select


        If Not pSym Is Nothing Then
            pUVRenderer.AddValue MyArray(j), "", pSym    ' "pFLayer.Name"Symbol is in the style gallery
            pUVRenderer.Label(MyArray(j)) = strSymCategory ' label in the TOC for the corresponding value

        Else
            If strSymCategory = "Default" Or strSymCategory = "" Then
                strSymCategory = "No style found, Default Symbol"   ' symbol is not in the style gallery
            End If

            pUVRenderer.AddValue MyArray(j), "", pSymDefault    ' "pFLayer.Name"symbol is not in the style gallery
                 ' label in the TOC for the corresponding default value
            strSymCategory = ""
        End If
    ElseIf Not pSym Is Nothing Then
        pUVRenderer.AddValue "0", "", pSym    'pFLayer.Name there is nothing in the ATC field so this will put the last symbol use as a default
        pUVRenderer.Label("0") = "Generic/Default" ' label in the TOC for the corresponding value
     Else
        pUVRenderer.AddValue "0", "", pSymDefault    'pFLayer.Name there is nothing in the ATC field so this will put the default symbol
        pUVRenderer.Label("0") = "Generic/Default" ' label in the TOC for the corresponding value
   End If

Next j
Dim strStyleGaleryName As String
strStyleGaleryName = frmSymbology.txtStyle & ".style"

pUVRenderer.LookupStyleset = strStyleGaleryName  ' set up the style name
pUVRenderer.UseDefaultSymbol = False            ' don't show default symbol
pUVRenderer.DefaultSymbol = pSymDefault


Set SomeLayer.Renderer = pUVRenderer  ' apply the renderer to the layer
Dim pRotation As IRotationRenderer

'**** apply a rotation if the angle field is found, this apply only for point/marker feature
If pBolAngle Then
Set pRotation = SomeLayer.Renderer
    pRotation.RotationField = "ANGLE"
    pRotation.RotationType = esriRotateSymbolArithmetic
End If


End Sub





Public Function GetStyleItem(StyleCategory As String, StyleName As String, ByRef Category As String) As IUnknown
'**********************
' this function go in the style library and return the matching Symbol
' return a symbol (point, line or fill)
'**********************

' get the style gallery
Dim pStyleGallery As IStyleGallery
Dim pstyleStorage As IStyleGalleryStorage
Static blstyle As Boolean
Set pStyleGallery = m_pMxDoc.StyleGallery
Set pstyleStorage = pStyleGallery

'get the list for the specific ntdb style
Dim pEnumStyleItems As IEnumStyleGalleryItem
'Set pEnumStyleItems = pStyleGallery.Items(StyleCategory, "BAntdb2.style", "")
Dim strStyleGaleryName As String
strStyleGaleryName = frmSymbology.txtStyle & ".style"   'get the name given by the user

If Not blstyle Then
    pstyleStorage.AddFile (strStyleGaleryName)
    blstyle = True
End If

Set pEnumStyleItems = pStyleGallery.Items(StyleCategory, strStyleGaleryName, "")

pEnumStyleItems.Reset

'If pEnumStyleItems Is Empty Then Exit Function
Dim pStyleGalleryItems As IStyleGalleryItem
On Error GoTo ErrorStyle
Set pStyleGalleryItems = pEnumStyleItems.Next

' find out if the style existe for this element
Do Until pStyleGalleryItems Is Nothing
    If pStyleGalleryItems.Name = StyleName Then Exit Do
    Set pStyleGalleryItems = pEnumStyleItems.Next
Loop

If Not pStyleGalleryItems Is Nothing Then
    Category = pStyleGalleryItems.Category  'get the category name for display
    Set GetStyleItem = pStyleGalleryItems.Item
Else
    Set GetStyleItem = Nothing
    Category = "Default"        'there is no symbology for the feature so use the default
End If

Exit Function
ErrorStyle:

MsgBox "Can't find the Style galery!!"
frmSymbology.Tag = "Error"
Exit Function

End Function