Layer Property Filters

Does anyone know how to create nested layer property filters in 2005 with VBA?
I have worked out how to create new filters without nesting and how to delete all filters including nested filters.

Regards - Nathan

Following code creates a filter named "TEXT" filtering for layers named "T-*"

Code:

Public Sub AddLayerFilters()
Dim objDict As AcadDictionary
Dim objFilter As AcadXRecord
Dim intXRDType(6) As Integer
Dim varXRDValue(6) As Variant
Set objDict = ThisDrawing.Layers.GetExtensionDictionary.AddObject("ACAD_LAYERFILTERS", "AcDbDictionary")
Set objFilter = objDict.AddXRecord("TEXT")
intXRDType(0) = 1:  varXRDValue(0) = "TEXT"
intXRDType(1) = 1:  varXRDValue(1) = "T-*"
intXRDType(2) = 1:  varXRDValue(2) = "*"
intXRDType(3) = 1:  varXRDValue(3) = "*"
intXRDType(4) = 70:  varXRDValue(4) = 0
intXRDType(5) = 1:  varXRDValue(5) = "*"
intXRDType(6) = 1:  varXRDValue(6) = "*"
objFilter.SetXRecordData intXRDType, varXRDValue
End Sub

Following code removes all filters including nested filters.

Code:

Public Sub RemoveLayerFilters()
Dim blnError As Boolean
Dim objDict As AcadDictionary
Dim objFilter As AcadXRecord
blnError = False
On Error GoTo ErrorHandler
Set objDict = ThisDrawing.Layers.GetExtensionDictionary.Item("AcLyDictionary")
On Error GoTo 0
If blnError = False Then
For Each objFilter In objDict
objFilter.Delete
Next objFilter
End If
blnError = False
On Error GoTo ErrorHandler
Set objDict = ThisDrawing.Layers.GetExtensionDictionary.Item("ACAD_LAYERFILTERS")
On Error GoTo 0
If blnError = False Then
For Each objFilter In objDict
objFilter.Delete
Next objFilter
End If
Exit Sub
ErrorHandler:
blnError = True
Resume Next
End Sub

 

Hopefully Layer Filter Manipulation will be added to the object model in the next release (http://forums.augi.com/showthread.php?t=4171). In the meantime though I worked out how a single layer of nesting is stored.

The main level of filters are stored as XRecords in a Dictionary named "ACAD_LAYERFILTERS" connected to the layers collection. For each of these records there is a corresponding XRecord in a Dictionary named "ACLYDICTIONARY" connected to the layers collection. Each of these records has a dictionary connected named "ACLYDICTIONARY" that contains the XRecords for the nested filters.

The following code prints all the Dictionaries and XRecords attached to the layers collection and the xdata attached to those objects:

Code:

Sub test()
Dim objDict As AcadDictionary
If ThisDrawing.Layers.HasExtensionDictionary Then
Set objDict = ThisDrawing.Layers.GetExtensionDictionary
Call test1(objDict)
End If
End Sub

Sub test1(objRec As AcadObject)
Dim objRec1 As AcadObject
Dim varXRDType As Variant
Dim varXRDValue As Variant
Dim intCount As Integer
objRec.GetXData "", varXRDType, varXRDValue
If VarType(varXRDType) <> vbEmpty Then
For intCount = 0 To UBound(varXRDType)
Debug.Print varXRDType(intCount) & " , " & varXRDValue(intCount) & " = XData"
Next intCount
End If
If TypeOf objRec Is AcadDictionary Then
For Each objRec1 In objRec
Debug.Print objRec1.Name & " = " & objRec1.ObjectName
Call test1(objRec1)
Next
ElseIf TypeOf objRec Is AcadXRecord Then
objRec.GetXRecordData varXRDType, varXRDValue
For intCount = 0 To UBound(varXRDType)
If varXRDType(intCount) = 290 Then
Debug.Print varXRDType(intCount) & " , " & varXRDValue(intCount) & " = XRecordData"
End If
Next intCount
End If
If objRec.HasExtensionDictionary Then
Set objRec1 = objRec.GetExtensionDictionary
Call test1(objRec1)
End If
End Sub

Regards - Nathan