Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- '********************************************
- '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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement