在CAD2006中自定义工具栏添加一个自编加法器程序.docVIP

在AUTOCAD2006中 添加一个自定义加法器工具 武汉市江夏区勘测院 金卫东 2007年7月 本人在用AUTOCAD软件作图的日常工作中，经常会遇到要用图上的数字注记，进行加减运算的简单计算工作。通常情况下，是调用系统的计算器程序，通过手工输入或复制粘贴的方式来完成这项工作。而这种方式较为繁琐，如果能够通过鼠标直接点取相应的数字注记，来得到最终的累加结果，这样就非常有效率且直截了当。 解决方法：在AUTOCAD2006中编写一个VBA程序add.dvb,通过自定义栏中定义一个工具“加法器”，来调用这个程序，即可达到目的。 1加法器add.dvb源程序 程序功能：通过在图上选择需要累加的数字注记，将其变为黄色，若数字注记中有等号，则仅取最后一个等号右侧的数字，依次累加，鼠标右键单击结束选择，在鼠标指定的位置标注计算结果。 ★注意，1）在使用这个工具的过程中，选择需要累加的数字注记时，鼠标左键不要双击，以免重复选中对象造成累加结果错误。 2）为确保结果正确，在累计的个数较多时，建议做两次运算，确认结果无误。 3）若选中的对象非数字注记，则相当于选中数字“0”。 AutoCAD对象，ThisDrawing代码 Option Explicit Dim mspaceObj As AcadText Dim sum As Double Dim cs As String Dim ns As Double Sub add() Dim basePnt As Variant Dim l As Integer Dim i As Integer, j As Integer Dim t As String Dim CurrentColor As Variant sum = 0 On Error Resume Next RETRY: ThisDrawing.Utility.GetEntity mspaceObj, basePnt, 请选择需要累加的数字注记 If Err 0 Then Err.Clear Dim prompt1 As String Dim startPnt As Variant Dim insPoint1(0 To 2) As Double 声明插入点 prompt1 = vbCrLf 指定放置位置: Dim textHeight As Double 声明文字高度 Dim textStrSum As String 声明字符串 Dim textObjSum As AcadText 声明文字对象 在不输入基点的情况下获取第一点 startPnt = ThisDrawing.Utility.GetPoint(, prompt1) insPoint1(0) = startPnt(0) insPoint1(1) = startPnt(1) insPoint1(2) = startPnt(2) textHeight = 1 文字高度设置为 1 textStrSum = LTrim(Str(sum)) 创建 Text 对象 Set textObjSum = ThisDrawing.ModelSpace.AddText _ (textStrSum, insPoint1, textHeight) Exit Sub Else CurrentColor = mspaceObj.color mspaceObj.color = acYellow 选中对象变黄色 mspaceObj.Update If mspaceObj.ObjectName = AcDbText Then cs = LTrim(mspaceObj.TextString) l = Len(cs): j