[VBA程序]：在屏幕上选择数字进行求和、和求积的程序

gjliang

Sub opsum()
Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim i As Integer
Dim a As Double
Dim ent As AcadEntity
For Each ent In ss
        a = ent.textString
        e = a
        d = d + e
        Dim ent2height As String
        ent2height = ent.height
        Next
f = FormatNumber(d, 3, vbture, , vbFalse)[/COLOR]
Dim text2 As String
ThisDrawing.Utility.InitializeUserInput 0, "1 2"
text2 = ThisDrawing.Utility.GetKeyword(vbCrLf & 选项"[更改(1)/插入(2)](1): ")
    If text2 = "" Or text2 = "1" Then text2 = "1"
        If text2 = "1" Then
        Dim ent1 As AcadEntity
        ThisDrawing.Utility.GetEntity ent1, pt1, "选择更改数字："
        ent1.textString = f
        End If
    If text2 = "2" Then
        Dim pt2 As Variant
        Dim ent2 As AcadText
        pt2 = ThisDrawing.Utility.GetPoint(, "插入：")
        Set ent2 = ThisDrawing.ModelSpace.AddText(f, pt2, ent2height)
    End If
End Sub

Sub opmul()
Dim ss As AcadSelectionSet
Set ss = GetSelSet
Dim ent As AcadEntity
Dim a As Double
Dim d As Double
d = 1
For Each ent In ss
    a = ent.textString
    e = a
    d = d * e
    Dim height As String
    height = ent.height
Next
f = FormatNumber(d, 3, vbture, , vbFalse)[/COLOR]
On Error Resume Next
ThisDrawing.Utility.InitializeUserInput 0, "1 2"
text2 = ThisDrawing.Utility.GetKeyword(vbCrLf & "选项[更改(1)/插入(2)](1): ")
    If text2 = "" Or text2 = "1" Then text2 = "1"
        If text2 = "1" Then
        Dim ent1 As AcadEntity
        ThisDrawing.Utility.GetEntity ent1, pt1, "选择更改数字："
        ent1.textString = f
        End If
    If text2 = "2" Then
        Dim pt2 As Variant
        Dim ent2 As AcadText
        pt2 = ThisDrawing.Utility.GetPoint(, "插入点：")
        Set ent2 = ThisDrawing.ModelSpace.AddText(f, pt2, height)
    End If
End Sub

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

本程序是本人为了方便统计材料表而写，因为除法和减法很少用到，所以没有写进，在进行材料表统计时只需要点鼠标就能轻松完成统计，但还是有一些bug的，譬如结果小数点后保留的位数就没办法和units里设置的形成一致；如果哪位朋友想使用可下载附件后解压至cad安装目录下的support目录下并把下面的语句拷贝到acad.mnl内，启动cad后运行sum进行求和，运行mul进行求积。
(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 "sum" "operation.dvb" "opsum")

(AutoVBALoad "mul" "operation.dvb" "opmul")
已经成功实现四舍五入和小数点前面的0保留功能[/COLOR]

liujiping

在屏幕上选择数字.“实时平移“ 或 “实时缩放
是个问题

gjliang

R2002没问题啊，用滚轮来进行移动和缩放。

WRHCHINA

求积的命令不是mul或opmul，应是什么命令？

gjliang

是mul啊，这样你可以打开acad.mnl文件看看，可以把命令改成你自己喜欢的单词的

陌生人

文本表达式混合计算程序演示 ，支持所有lsp运算符和表达式，支持选择图纸中数字文本进行计算。拟加入支持封闭曲线实体面积计算
http://www.xdcad.net/forum/showthread.php?s=&threadid=144058

ksh2003

提高工作效率的有效工具：

操作数、计算结果均为一组文本

具有选择一列、一行的功能，用它修改钢筋数量表是一件非常轻松的事情

计算结果不用手工输入，只需用鼠标拾取

如果你喜欢计算器或者觉得不用计算器浪费，这个程序不适合你

                               
登录/注册后可看大图

blue_space

好东西，先谢了