分段标注多段线线长

kkq0305

又在重复造轮子了，大佬看看有什么地方优化一下
;;;分段标注线长
(defun c:tt (/ zg ss obj lst n l lst lst1 lst2 lst3 obj1 obj2)
  (prompt "\n请选择需要标注的线：")
(setq zg 300);;; 字高可自定义
  (if (setq ss (ssget ":S:E" '((0 . "LWPOLYLINE"))))
    (progn
      (setq obj        (vlax-ename->vla-object (ssname ss 0))
            lst        nil
            n        -1
      )
      (while (setq l (vlax-curve-getDistAtParam obj (setq n (1+ n))))
        (setq lst (cons l lst))
      )
      (setq lst         (reverse lst)
            lst1 (mapcar '(lambda (a b) (- b a)) lst (cdr lst))
      )
      (setq
        lst2 (mapcar '(lambda (x) (vlax-curve-getPointAtDist obj x))
                     (mapcar '(lambda (a b) (+ a (* 0.5 b))) lst lst1)
             )
      )
      (setq lst3
             (mapcar '(lambda (x)
                        (setq
                          ang (angle
                                x
                                (mapcar        '+
                                        x
                                        (vlax-curve-getFirstDeriv
                                          obj
                                          (vlax-curve-getParamAtPoint obj x)
                                        )
                                )
                              )
                        )
                        (if (< (* 0.5 pi) ang (* 1.5 pi))
                          (- ang pi)
                          ang
                        )
                      )
                     lst2
             )
      )
      (setq obj1 (car (vlax-safearray->list
                        (vlax-variant-value (vla-offset obj zg))
                      )
                 )
            obj2 (car (vlax-safearray->list
                        (vlax-variant-value (vla-offset obj (- zg)))
                      )
                 )
      )
      (or (> (vla-get-Length obj1) (vla-get-Length obj2))
          (vla-Delete obj1)
          (setq        obj1 obj2
                obj2 nil
          )
      )
      (and obj2 (vla-Delete obj2))
      (setq lst2
             (mapcar '(lambda (x) (vlax-curve-getClosestPointTo obj1 x))
                     lst2
             )
      )
      (vla-Delete obj1)
      (mapcar '(lambda (a b c)
                 (entmake (list        '(0 . "TEXT")
                                (cons 1 (rtos a 2 2))
                                (cons 10 b)
                                (cons 40 zg)
                                (cons 11 b)
                                '(72 . 1)
                                '(73 . 2)
                                (cons 50 c)
                          )
                 )
               )
              lst1
              lst2
              lst3
      )
    )
  )
  (princ)
)

huaxiamengqing

CAD中可视化编程Grasshopper分段标注线长



感兴趣可以查看这个帖子直接下载使用，任何组合功能，数十万函数可以免费直接拖用。
http://bbs.mjtd.com/thread-189349-1-1.html

kkq0305

guosheyang 发表于 2023-4-2 12:10
感谢递归哥的共享 ！  对于多段线 圆弧和 样条线组合的复合型样条线  如果不炸开的话  能否实现分段标注   ...

只支持多段线 多段线 只有圆弧和直线组成吧

chenxiy825

kkq0305 发表于 2023-4-2 17:03
哈哈  还有apply  看看我写的 多琢磨下  下次写出更有意思的代码

是的，这三个函数会了就学Autolisp简单多了。你上面写的还是有看不太明白的地方

lxl217114

感觉加个字高的设置：
标注单位、精确位数，字高

kkq0305

lxl217114 发表于 2023-4-2 11:28
感觉加个字高的设置：
标注单位、精确位数，字高

这个 接口都有

guosheyang

感谢递归哥的共享 ！  对于多段线 圆弧和 样条线组合的复合型样条线  如果不炸开的话  能否实现分段标注  确定字段似乎不好弄 可以尝试下   

hzyhzjjzh

谢谢楼主分享

chenxiy825

mapcar 和lambda函数用的这么溜，看到这两个函数我就头大

kkq0305

chenxiy825 发表于 2023-4-2 16:41
mapcar 和lambda函数用的这么溜，看到这两个函数我就头大

哈哈  还有apply  看看我写的 多琢磨下  下次写出更有意思的代码

aws

第一个文字碰撞了，第二个的结果，有点奇怪

kkq0305

aws 发表于 2023-4-2 17:08
第一个文字碰撞了，第二个的结果，有点奇怪

原来如此   我还奇怪调试的时候返回值怎么是一个表 懂了