oh this is dream
I want to make material report for AECobject in Autocad Architecture
The only method to calculate fine is command "Materiallist"
I've made is macro that
1. makes property set deffinition for (AECwall)
2.creates property"material"
3. serching for AECwall in current drawing
4. select it and run materiallist command for every AECwall
5. MiSSED PART(capture value from command line and filtering it) but filtering not a problam
6. wright it to property
I made chek wrighting ID of every AECwall to property"material" it works
so there is another way only I see now
Manually copy history of autocad window text and copy it to excel file
then run another script to capture date and apply it to AECwall
that how it looks now
Sub materiallist()
Dim SchedApp As New AecScheduleApplication
Dim cProps As AecScheduleProperties
Dim PropSetDefs As AecSchedulePropertySetDefs
Dim propsetdef As AecSchedulePropertySetDef
Dim propertyDefs As AecSchedulePropertyDefs
Dim propertydef As AecSchedulePropertyDef
Dim propertyset As AecSchedulePropertySet
Dim propertysets As AecSchedulePropertySets
Dim obj As AcadObject
Dim msg As String
Dim PrSetDefName As String
Dim propertydefname As String
PrSetDefName = "Wall_Materiallist"
propertydefname = "Materiall"
'_______________________________create property set________________________________
On Error Resume Next
' Access the set of property definitions.
Set propsetdef = PropSetDefs(PrSetDefName)
' If set of property definitions isn't created then create it.
If propsetdef Is Nothing Then
PropSetDefs.Add (PrSetDefName)
Set PropSetDefs = SchedApp.PropertySetDefs(ThisDrawing.Database)
Set propsetdef = PropSetDefs(PrSetDefName)
End If
' Now add a property definition to the new set of definitions.
Set propertyDefs = propsetdef.propertyDefs
On Error Resume Next
Set propertydef = propertyDefs(propertydefname)
' If set of property definitions name isn't created then create it.
If propertydef Is Nothing Then
propertyDefs.Add (propertydefname)
Set propertydef = propertyDefs(propertydefname)
End If
' Access the definition just created, and set some properties.
Set propertydef = propertyDefs(propertydefname)
propertydef.Description = "materiall from materiallst."
propertydef.Format = "Standard"
propertydef.Type = aecSchedulePropertyTypeText
'_________________________________counting materiallist______________________________________
Dim ent As AcadEntity
Dim geo As AecGeo
Dim wall As AecWall
Dim findObj As AcadObject
Dim point(0 To 2) As Double
Dim sset As AcadSelectionSet
For Each ent In ThisDrawing.ModelSpace
If TypeOf ent Is AecWall Then
Set wall = ent
Set sset = ThisDrawing.SelectionSets.Add("SS10")
ObjectID = wall.ObjectID
Set findObj = ThisDrawing.ObjectIdToObject(ObjectID)
point(0) = wall.Location(0): point(1) = wall.Location(1): point(2) = wall.Location(2)
sset.SelectAtPoint point
If sset.Count > 0 Then
ThisDrawing.Utility.Prompt "ID " & ObjectID
ThisDrawing.SendCommand "Select p " & vbCrLf
ThisDrawing.SendCommand "Materiallist" & vbCr & vbCr
ThisDrawing.Utility.Prompt "ID " & ObjectID
'________________apply property to walls _____________________
Set propertysets = SchedApp.propertysets(wall)
' Add a new property set. Notice that the Add method requires
' a property set definition argument, not a property set.
propertysets.Add propsetdef
'___________________________adding value to property set and_____________________
Dim retval As String
retval = CStr(ObjectID)
Set propertysets = SchedApp.propertysets(wall)
On Error Resume Next
Set propertyset = propertysets.Item("Wall_Materiallist")
If Not propSet Is Nothing Then
Set cProps = propertyset.Properties
cProps.Item("Materiall").Value = retval
ThisDrawing.SelectionSets("SS10").Delete
End If
End If
Else
Set ent = Nothing
End If
Next
End Sub
