社区 › AutoLISP/Visual LISP 编程技术 › 求高手修改多段线自动编号标注长度程序

jack11280 发表于 2012-12-16 15:47:31

求高手修改多段线自动编号标注长度程序

在本论坛收集了一个多段线自动编号标注长度想请高手改一下
原程序对只能标在图纸上希望能有大大帮忙改一下让也可以顺便输出至Excel
在此贴出程序原文希望能有人帮忙


;;;BY X_S_S_1
(vl-load-com)
(defun c:la (/
                ss
                qz
                lst
                length_lst
                en
                pt_lst
                curve-obj
                dist
                s_lst
                n
                pt
                tl
               )
(defun x_ssn (ss / n lst)
    (repeat (setq N (sslength ss))
      (setq LST (cons (ssname SS (setq N (1- N))) LST))
    )
)
(defun emk_t (layer pt1 pt2 text ang n72 n73 h /)
    (entmake (list '(0 . "text")
                   '(100 . "AcDbEntity")
                   (cons 8 layer)
                   '(100 . "AcDbText")
                   (cons 10 pt1)
                   (cons 1 text)
                   (cons 40 h)
                   '(41 . 0.75)
                   '(7 . "standard")
                   (cons 72 n72)
                   (cons 11 pt2)
                   (cons 50 ang)
                   (cons 73 n73)
             ) ;_ 结束list
    ) ;_ 结束entmake
) ;_ 结束defun
(SETQ SS (SSGET '((0 . "*LINE,CIRCLE,ARC,ELLIPSE"))))
(setq qz (getstring "\n前缀:"))
(setq lst (x_ssn ss))
(setq      length_lst
         (mapcar '(lambda (en)
                  (vlax-curve-getDistAtParam
                      en
                      (vlax-curve-getEndParam en)
                  )
                  )
               lst
         )
)
(setq
    pt_lst (mapcar '(lambda (curve-obj dist)
                      (vlax-curve-getPointAtDist curve-obj (/ dist 2))
                  )
                   lst
                   length_lst
         )
)
(setq s_lst nil)
(repeat (setq n (length length_lst))
    (setq s_lst      (cons (strcat qz
                              (itoa n)
                              "="
                              (rtos (nth (1- n) length_lst) 2 2)
                      )
                      s_lst
                )
    )
    (setq n (1- n))
)
(mapcar '(lambda (pt tl) (emk_t "0" pt pt tl 0 1 0 250));此句可以将(emk_t "0" pt pt tl 0 1 0 250))做变量(250改文字大小)
          pt_lst
          s_lst
)
)

jack11280 发表于 2012-12-17 11:08:46

再頂一下

梦里水香 发表于 2012-12-17 17:05:03

好程序，帮忙顶一个，字体要是可以自定义大小就好了，要是字与线对齐就更好了。。

jack11280 发表于 2012-12-18 11:36:17

我也在等高手完善這程序

jack11280 发表于 2012-12-19 11:17:41

我再頂一直頂

bai2000 发表于 2012-12-19 12:00:35

能自定义高度并写在图上，更好

jack11280 发表于 2012-12-21 10:27:18

我再頂一直頂

香田里浪人 发表于 2013-1-27 20:11:11

编程精神可嘉，使用价值不大，已经有人编程面积周长输出excel

jkop 发表于 2023-8-16 11:36:30

很方便的线段编码程序，希望有大神出手，协助修改。

查看完整版本: 求高手修改多段线自动编号标注长度程序