|
The Code
Function GetPropertySetDefinitions() As Variant
Dim sch As New AecScheduleApplication, psd As AecSchedulePropertySetDef, cnt As Long, defs() As String
cnt = 0
For Each psd In sch.PropertySetDefs(ThisDrawing.Database)
ReDim Preserve defs(cnt)
defs(cnt) = psd.Name
cnt = cnt + 1
Next
GetPropertySetDefinitions = defs
End Function
Function GetPropertyDefs(ByVal psdName As String) As Variant
Dim sch As New AecScheduleApplication, psd As AecSchedulePropertySetDef, _
psds As AecSchedulePropertySetDefs, cnt As Long, defs() As String, _
pDef As AecSchedulePropertyDef
cnt = 0
Set psds = sch.PropertySetDefs(ThisDrawing.Database)
If psds.Has(psdName) Then
Set psd = psds(psdName)
For Each pDef In psd.PropertyDefs
ReDim Preserve defs(cnt)
defs(cnt) = pDef.Name
cnt = cnt + 1
Next
GetPropertyDefs = defs
End If
End Function
Function GetPropertyDef(ByVal psdName As String, ByVal pdName As String) As AecSchedulePropertyDef
Dim sch As New AecScheduleApplication, psd As AecSchedulePropertySetDef, _
psds As AecSchedulePropertySetDefs, cnt As Long, defs() As String, pDef As AecSchedulePropertyDef
On Error GoTo errTrap
Set psds = sch.PropertySetDefs(ThisDrawing.Database)
If psds.Has(psdName) Then
Set psd = psds(psdName)
Set GetPropertyDef = psd.PropertyDefs(pdName)
End If
errTrap:
End Function
Sub CreatePropertySetDefinition(ByVal psdName As String)
Dim sch As New AecScheduleApplication, psd As AecSchedulePropertySetDef, _
psds As AecSchedulePropertySetDefs, cnt As Long, defs() As String, pDef As AecSchedulePropertyDef
On Error GoTo errTrap
Set psds = sch.PropertySetDefs(ThisDrawing.Database)
If Not (psds.Has(psdName)) Then
psds.Add (psdName)
End If
errTrap:
End Sub
Function CreatePropertyDef(ByVal psdName As String, ByVal pdName As String) As AecSchedulePropertyDef
Dim sch As New AecScheduleApplication, psd As AecSchedulePropertySetDef, psds As AecSchedulePropertySetDefs
On Error Resume Next
Err.Clear
Set psds = sch.PropertySetDefs(ThisDrawing.Database)
If psds.Has(psdName) Then
Set psd = psds(psdName)
Set CreatePropertyDef = psd.PropertyDefs(pdName)
If CreatePropertyDef Is Nothing Then Set CreatePropertyDef = psd.PropertyDefs.Add(pdName)
End If
End Function
Function GetAppliestoList(ByVal psdName As String) As Variant
Dim sch As New AecScheduleApplication, psd As AecSchedulePropertySetDef, psds As AecSchedulePropertySetDefs
On Error Resume Next
Err.Clear
Set psds = sch.PropertySetDefs(ThisDrawing.Database)
If psds.Has(psdName) Then
Set psd = psds(psdName)
GetAppliestoList = psd.AppliesTo
If UBound(GetAppliestoList) = -1 Then GetAppliestoList = Null
End If
End Function
Sub SetAppliestoList(ByVal psdName As String, Lst As Variant)
Dim sch As New AecScheduleApplication, psd As AecSchedulePropertySetDef, psds As AecSchedulePropertySetDefs
Set psds = sch.PropertySetDefs(ThisDrawing.Database)
If psds.Has(psdName) Then
Set psd = psds(psdName)
If IsArray(Lst) Then
psd.AppliesTo = Lst
End If
End If
End Sub
Function GetAllThatApply(ByVal objName As String) As Variant
Dim psds, i As Long, ii As Long, appLst, Lst(), cnt As Long
psds = GetPropertySetDefinitions
cnt = 0
For i = 0 To UBound(psds)
appLst = GetAppliestoList(psds(i))
If IsNull(appLst) Then
ReDim Preserve Lst(cnt)
Lst(cnt) = psds(i)
cnt = cnt + 1
Else
For ii = 0 To UBound(appLst)
If StrComp(objName, appLst(ii), 1) = 0 Then
ReDim Preserve Lst(cnt)
Lst(cnt) = psds(i)
cnt = cnt + 1
End If
Next
End If
Next
GetAllThatApply = Lst
End Function
Function GetDataFormatStyles() As Variant
Dim dicts As AcadDictionaries, dict As AcadDictionary, cnt As Long, rec As AecDictRecord, v()
Set dicts = ThisDrawing.Dictionaries
On Error Resume Next
cnt = 0
Set dict = dicts("AEC_PROPERTY_FORMAT_DEFS")
If Not (dict Is Nothing) Then
For Each rec In dict
ReDim Preserve v(cnt)
v(cnt) = rec.Name
cnt = cnt + 1
Next
End If
GetDataFormatStyles = v
End Function
Sub AttachScheduleData(obj As AcadObject, ByVal psdName As String)
Dim sch As New AecScheduleApplication, propSets As AecSchedulePropertySets
Set propSets = sch.PropertySets(obj)
propSets.Add sch.PropertySetDefs(ThisDrawing.Database)(psdName)
End Sub
Function GetScheduleDataList(obj As AcadObject) As Variant
Dim sch As New AecScheduleApplication, propSet As AecSchedulePropertySet, cnt As Long, v()
cnt = 0
For Each propSet In sch.PropertySets(obj)
ReDim Preserve v(cnt)
v(cnt) = propSet.Name
cnt = cnt + 1
Next
GetScheduleDataList = v
End Function
Function GetScheduleData(obj As AcadObject, ByVal psdName As String) As AecSchedulePropertySet
Dim sch As New AecScheduleApplication, propSets As AecSchedulePropertySets
Set propSets = sch.PropertySets(obj)
Set GetScheduleData = propSets(psdName)
End Function
Function GetScheduleDataItem(obj As AcadObject, ByVal psdName As String, ByVal propName As String) As AecScheduleProperty
Dim sch As New AecScheduleApplication, propSets As AecSchedulePropertySets
Set propSets = sch.PropertySets(obj)
Set GetScheduleDataItem = propSets(psdName).Properties(propName)
End Function
Function AttachScheduleTag(obj As AcadObject, ByVal mvbName As String, pt As Variant) As AecMVBlockRef
Dim anch As New AecAnchorTagToEnt
Set AttachScheduleTag = ThisDrawing.ModelSpace.AddCustomObject("AecMVBlockRef")
AttachScheduleTag.Location = pt
AttachScheduleTag.StyleName = mvbName
AttachScheduleTag.Update
anch.Reference = obj
AttachScheduleTag.AttachAnchor anch
End Function
| 
