免费视频|新人指南|投诉删帖|广告合作|地信网APP下载

查看: 2501|回复: 2
收起左侧

[软件] 求助:哪位大神有一条直线多段注记相加成一个注记的小程序

[复制链接]

10

主题

2585

铜板

2

好友

助理工程师

Rank: 5Rank: 5

积分
319
发表于 2018-9-19 13:22 手机频道 | 显示全部楼层 |阅读模式
哪位大神有一条直线多段注记相加成一个注记的小程序
头像被屏蔽

141

主题

980万

铜板

3万

好友

管理员

Rank: 20Rank: 20Rank: 20Rank: 20Rank: 20

积分
627184
发表于 2018-9-19 13:50 | 显示全部楼层
提示: 作者被禁止或删除 内容自动屏蔽
回复 支持 反对

使用道具 举报

11

主题

1万

铜板

35

好友

地信名人堂

Rank: 19Rank: 19Rank: 19Rank: 19Rank: 19Rank: 19

积分
1687

精华勋章宣传勋章爱心勋章组织勋章地信元老灌水勋章荣誉会员勋章活跃勋章地信专家组VIP勋章贡献勋章名人堂勋章成就学员勋章

发表于 2018-9-19 21:30 | 显示全部楼层
以前在明经收集的
;;===================求和===================
(DEFUN C:sum()
  (setvar "cmdecho" 0)
  (setq jd (getint "input 精度<0>:"))
  (if (= jd nil) (setq jd 0))
        (setq s (ssget '((1 . "*[0-9]*")))) ;选择含数字文本
  (setq k -1 mm 0.0 numdb '())
        (setq h2(cdr(assoc 40 (entget (ssname s 0)))))
  (repeat (sslength s)
      (setq a (entget (ssname s (setq k(1+ k)))))
      (setq tx (cdr (assoc '1 a)))
                  (setq b (StrType tx)k2 -1)
                (repeat (length b)
                        (setq txt2(nth (setq k2(1+ k2))b))
                        (if (numberp (read txt2))
      (setq mm (+ (atof txt2) mm) numdb (cons txt2 numdb)))
                )
  )
        (setq numdb(reverse numdb))
        (setq mm (strcat (strcat (car numdb) (apply 'strcat (mapcar '(lambda (x) (strcat "+" x)) (cdr numdb)))) "=" (rtos mm 2 jd)))
;  (setq mm (rtos mm 2 jd))  ;仅显示计算结果
  (initget "1 2")
  (setq fs(getkword "\n(1)新建文本 (2)覆盖文本<1>:"))
  (cond
          ((or(= fs "1")(= fs nil))
     (setq po (getpoint "\n指定计算结果的写入点:"))
                 (entmake (list '(0 . "TEXT") (cons 1 mm)(cons 8 "0")(cons 10 po)(cons 40 h2)(cons 62 7)))
          )
          ((= fs "2")
                  (while(/= (cdr(assoc 0 (setq en (entget(car (entsel "\n请选择要覆盖的文本: ")))))) "TEXT"))
                  (entmod (subst (cons 1 mm) (assoc 1 en) en))
          )
  )
  (setvar "cmdecho" 1)
        (princ)
)
(defun StrType(a / b c d e);;字符串分离全角、符号、字母、数字,存在问题:连续小数点与数字相连不能精确分离数字和小数点
  (setq b(vl-string->list a))
  (while b
    (setq a(car b)b(cdr b)c(last d))
    (if(or(not d)
               (and(< 0 a 32)(< 0 c 32));;非打印字符
               (or(= 46 a)(= 46 c)(and(< 47 a 58)(< 47 c 58)));数字和小数点
                           (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((31 48)(57 65)(90 98)(122 129))))(list a c));其它字符包括小数点
               (vl-every'(lambda(x)(vl-some'(lambda(y)(<(car y)x(cadr y)))'((64 91)(96 123))))(list a c));;字母
             (and(> a 128)(> c 128)));;全角字符
       (if(> a 128)(setq d(vl-list*(car b)a d)b(cdr b))(setq d(cons a d)))
       (setq e(cons(reverse d)e)d(if(> a 128)(list(car b)a)(List a))b(if(> a 128)(cdr b)b))
                )
        )
  (mapcar'vl-list->string(reverse(cons(reverse d)e)))
)

评分

参与人数 1威望 +20 铜板 +80 收起 理由
jimi21 + 20 + 80 感谢回复!

查看全部评分

回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

在线客服
快速回复 返回顶部 返回列表