Hi guys,
First post here... I work in GIS, using ArcGIS 9.2, and I am a complete newby to VBA macro's scripts etc.
I hope this is the right place to post this (did a search for VBA and this thread seem to come up).
Basically I only started using VBA because a user wanted to add a count of unique values to one of his shapefiles, and then the count to appear in his legend.
The count field displays the count when in layer properies>unique values, but as soon as you come out of that the count ends.
So I found a macro which takes existing Unique Value and calculates feature counts for each value, adding the count to each Class Label. Class Labels appear in the ArcMap Table of Contents and Legend.
After a bit of trial and error I got the script to work. The problem is the script doesn't work on every shapefile, it works on some but not others.
Here is the script;
Const DESCRIP_FIELD = "STATE_NAME"
Const CONCATENATE_TO_BUILD_DESCRIPTION = True
Const CONCAT_CHAR = vbNewLine
Option Explicit
Sub UniqueValues_LabelCount_and_DescripFromField()
Dim pDoc As IMxDocument
Set pDoc = ThisDocument
Dim pMap As IMap
Set pMap = pDoc.FocusMap
Dim pGeoLayer As IGeoFeatureLayer
Set pGeoLayer = pMap.Layer(0)
If Not TypeOf pGeoLayer.Renderer Is IUniqueValueRenderer Then
MsgBox "Current symbology is not Unique values. Exiting."
Exit Sub
End If
Dim pUVRend As IUniqueValueRenderer
Set pUVRend = pGeoLayer.Renderer
If pUVRend.FieldCount > 1 Then
MsgBox "Current Unique values symbology is based on multiple fields. Exiting."
Exit Sub
End If
Dim sFieldName As String
sFieldName = pUVRend.Field(0)
Dim i As Integer
Dim varValue As Variant
Dim pFeatClass As IFeatureClass
Set pFeatClass = pGeoLayer.FeatureClass
Dim varLabelDescrip As Variant
For i = 0 To pUVRend.ValueCount - 1
varValue = pUVRend.Value(i)
varLabelDescrip = GetLabelDescription(pFeatClass, pUVRend.Field(0), varValue)
pUVRend.Label(varValue) = varLabelDescrip(0)
pUVRend.Description(varValue) = varLabelDescrip(1)
Next i
pDoc.ActiveView.ContentsChanged
pDoc.UpdateContents
pDoc.ActiveView.Refresh
End Sub
Private Function GetLabelDescription(pFeatClass As IFeatureClass, ValField As String, Value As Variant) As Variant
' returns an array of length 2
' (0) is the new label (string) appended with count of features
' (1) is the new descrip (string) driven from DESCRIP_FIELD
Dim pQueryFilter As IQueryFilter
Set pQueryFilter = New QueryFilter
pQueryFilter.WhereClause = ValField & " = '" & CStr(Value) & "'"
pQueryFilter.AddField DESCRIP_FIELD
Dim pFeatCursor As IFeatureCursor
Set pFeatCursor = pFeatClass.Search(pQueryFilter, False)
' ---------------------------------------------------------
' Description
Dim pFeat As IFeature
Dim sDescrip As String
Dim iDescrip As Integer
iDescrip = pFeatClass.Fields.FindField(DESCRIP_FIELD)
Set pFeat = pFeatCursor.NextFeature
Dim iCount As Integer
iCount = 0
Dim bCountsDetermined As Boolean
bCountsDetermined = False
If CONCATENATE_TO_BUILD_DESCRIPTION Then
bCountsDetermined = True
Do While Not pFeat Is Nothing
iCount = iCount + 1
If sDescrip <> "" Then sDescrip = sDescrip + CONCAT_CHAR
sDescrip = sDescrip + CStr(pFeat.Value(iDescrip)) ' get value from DESCRIP_FIELD
Set pFeat = pFeatCursor.NextFeature
Loop
Else ' only get descrip from first feature found
If Not pFeat Is Nothing Then
sDescrip = CStr(pFeat.Value(iDescrip)) ' get value from DESCRIP_FIELD
End If
End If
' ---------------------------------------------------------
' Label
If Not bCountsDetermined Then
' optimization: re-query only if we don't
' already have the counts from above
iCount = pFeatClass.FeatureCount(pQueryFilter)
End If
Dim sLabel As String
sLabel = Value & " (" & iCount & ") "
' ---------------------------------------------------------
' setup return array and return
Dim sReturnArray(2) As String
sReturnArray(0) = sLabel
sReturnArray(1) = sDescrip
GetLabelDescription = sReturnArray
End Function
I modify the constants for my particular data and situation (so essentially change 'STATE_NAME' to whatever the field im using is), it worked for the particular shapefile our user was using, but out of interest I tried it with a few other shapefiles, and it works for some and not others, the error message sometimes varies, but the latest one read ' Run-time error '-2147220985 (80040207) Automation error. The owner SID on a per-user subscription doesn't exist'.
Like I said above, I am a complete newby to this, and only started using it last week... it could be something obvious, so apologies if so.
Any help appreciated :)
Dan
First post here... I work in GIS, using ArcGIS 9.2, and I am a complete newby to VBA macro's scripts etc.
I hope this is the right place to post this (did a search for VBA and this thread seem to come up).
Basically I only started using VBA because a user wanted to add a count of unique values to one of his shapefiles, and then the count to appear in his legend.
The count field displays the count when in layer properies>unique values, but as soon as you come out of that the count ends.
So I found a macro which takes existing Unique Value and calculates feature counts for each value, adding the count to each Class Label. Class Labels appear in the ArcMap Table of Contents and Legend.
After a bit of trial and error I got the script to work. The problem is the script doesn't work on every shapefile, it works on some but not others.
Here is the script;
Const DESCRIP_FIELD = "STATE_NAME"
Const CONCATENATE_TO_BUILD_DESCRIPTION = True
Const CONCAT_CHAR = vbNewLine
Option Explicit
Sub UniqueValues_LabelCount_and_DescripFromField()
Dim pDoc As IMxDocument
Set pDoc = ThisDocument
Dim pMap As IMap
Set pMap = pDoc.FocusMap
Dim pGeoLayer As IGeoFeatureLayer
Set pGeoLayer = pMap.Layer(0)
If Not TypeOf pGeoLayer.Renderer Is IUniqueValueRenderer Then
MsgBox "Current symbology is not Unique values. Exiting."
Exit Sub
End If
Dim pUVRend As IUniqueValueRenderer
Set pUVRend = pGeoLayer.Renderer
If pUVRend.FieldCount > 1 Then
MsgBox "Current Unique values symbology is based on multiple fields. Exiting."
Exit Sub
End If
Dim sFieldName As String
sFieldName = pUVRend.Field(0)
Dim i As Integer
Dim varValue As Variant
Dim pFeatClass As IFeatureClass
Set pFeatClass = pGeoLayer.FeatureClass
Dim varLabelDescrip As Variant
For i = 0 To pUVRend.ValueCount - 1
varValue = pUVRend.Value(i)
varLabelDescrip = GetLabelDescription(pFeatClass, pUVRend.Field(0), varValue)
pUVRend.Label(varValue) = varLabelDescrip(0)
pUVRend.Description(varValue) = varLabelDescrip(1)
Next i
pDoc.ActiveView.ContentsChanged
pDoc.UpdateContents
pDoc.ActiveView.Refresh
End Sub
Private Function GetLabelDescription(pFeatClass As IFeatureClass, ValField As String, Value As Variant) As Variant
' returns an array of length 2
' (0) is the new label (string) appended with count of features
' (1) is the new descrip (string) driven from DESCRIP_FIELD
Dim pQueryFilter As IQueryFilter
Set pQueryFilter = New QueryFilter
pQueryFilter.WhereClause = ValField & " = '" & CStr(Value) & "'"
pQueryFilter.AddField DESCRIP_FIELD
Dim pFeatCursor As IFeatureCursor
Set pFeatCursor = pFeatClass.Search(pQueryFilter, False)
' ---------------------------------------------------------
' Description
Dim pFeat As IFeature
Dim sDescrip As String
Dim iDescrip As Integer
iDescrip = pFeatClass.Fields.FindField(DESCRIP_FIELD)
Set pFeat = pFeatCursor.NextFeature
Dim iCount As Integer
iCount = 0
Dim bCountsDetermined As Boolean
bCountsDetermined = False
If CONCATENATE_TO_BUILD_DESCRIPTION Then
bCountsDetermined = True
Do While Not pFeat Is Nothing
iCount = iCount + 1
If sDescrip <> "" Then sDescrip = sDescrip + CONCAT_CHAR
sDescrip = sDescrip + CStr(pFeat.Value(iDescrip)) ' get value from DESCRIP_FIELD
Set pFeat = pFeatCursor.NextFeature
Loop
Else ' only get descrip from first feature found
If Not pFeat Is Nothing Then
sDescrip = CStr(pFeat.Value(iDescrip)) ' get value from DESCRIP_FIELD
End If
End If
' ---------------------------------------------------------
' Label
If Not bCountsDetermined Then
' optimization: re-query only if we don't
' already have the counts from above
iCount = pFeatClass.FeatureCount(pQueryFilter)
End If
Dim sLabel As String
sLabel = Value & " (" & iCount & ") "
' ---------------------------------------------------------
' setup return array and return
Dim sReturnArray(2) As String
sReturnArray(0) = sLabel
sReturnArray(1) = sDescrip
GetLabelDescription = sReturnArray
End Function
I modify the constants for my particular data and situation (so essentially change 'STATE_NAME' to whatever the field im using is), it worked for the particular shapefile our user was using, but out of interest I tried it with a few other shapefiles, and it works for some and not others, the error message sometimes varies, but the latest one read ' Run-time error '-2147220985 (80040207) Automation error. The owner SID on a per-user subscription doesn't exist'.
Like I said above, I am a complete newby to this, and only started using it last week... it could be something obvious, so apologies if so.
Any help appreciated :)
Dan