[VBA函数]：用属性块进行材料表统计

gjliang

Sub cal()
Dim ent As Object
Dim attvar As Variant
Dim attri As String
Dim height As Double
Dim ss As AcadSelectionSet
Set ss = GetSelSet
    For Each ent In ss
        If TypeOf ent Is AcadBlockReference Then
            attvar = ent.GetAttributes
            height = ent.XScaleFactor
            End If
            attri = ""
Dim i As Integer
i = 0
    For i = LBound(attvar) To UBound(attvar)
Dim a As Double
Dim b As Double
Dim c As Variant
On Error Resume Next
    a = attvar(3).textString
    b = attvar(4).textString
    c = a * b
    attvar(5).textString = c
    e = c / 8
    d = d + e
    Next
    Next
Dim newtext As AcadText
Dim pt1 As Variant
On Error Resume Next
pt1 = ThisDrawing.Utility.GetPoint(, "总和插入点：")
Set newtext = ThisDrawing.ModelSpace.AddText(d, pt1, 3.5 * height)

Function GetSelSet() As AcadSelectionSet
    Dim ss As AcadSelectionSet
    Dim ssName As String
    ssName = "PICKFIRST"
    On Error Resume Next
    Set ss = ThisDrawing.SelectionSets.add(ssName)
    If Err Then
        Set ss = ThisDrawing.SelectionSets(ssName)
        ss.Delete
    End If
    Set ss = ThisDrawing.PickfirstSelectionSet
    If ss.Count = 0 Then
        Set ss = ThisDrawing.SelectionSets(ssName)
        If Err Then Set ss = ThisDrawing.SelectionSets.add(ssName)
        ss.Clear
        ss.SelectOnScreen
    End If
    Set GetSelSet = ss
    ThisDrawing.SetVariable "filedia", 1
End Function
本程序为用属性块进行材料表统计的程序，属性块为外部块，当数据输入完成后只需要用鼠标选取一下需要进行统计的材料就可以自动进行统计，并得出合计的结果。（但考虑到各人的情况不同，所以本程序只是给大家一个思路而已）
想查看本程序效果可下载附件后解压至cad安装目录下的support目录下并把下面这段文字拷贝进acad.mnl文件内。
(vl-load-com)
;;自动加载VBA程序的函数
(defun AutoVBALoad (cmdname project macro)
(eval
(list 'defun
(read (strcat "C:" cmdname))
nil
(list
'vl-vbarun
(strcat
project
"!"
(if macro
macro
cmdname
)
)
)
(princ)
)
)
)

(AutoVBALoad "cal" "cal.dvb" "cal")
如果已经有过这个函数定义，只需把(AutoVBALoad "cal" "cal.dvb" "cal")
复制到acad.mnl内即可,然后打开附件内的sample文件，运行cal选择材料表查看结果。

gjliang

使用演示
下载到硬盘进行全屏观看会比较清晰

laijiafu527

没有看明白,怎么用呀!