组装工-点多段线选线内实体

tigcat

所有代码都是复制组装的。有很多bug，每个子函数版权归原作者所有，我并没有特意删除作者信息，若有问题，联系我删除。发帖是看大家会不会在特定情况下需要。最大特点是屏幕外可以选取。
功能：点击一条多段线，以cp方式选中闭合多段线内的物体。
复制树兄的代码，原帖地址：http://bbs.mjtd.com/forum.php?mo ... 90&page=1#pid881597程序可以适用某些特定需求，比如检查计算书截面


(defun makepl (argments)
  ;;argments==>(list pts 闭合标志 全局宽度 线宽 图层 颜色 厚度 线型)pts以后可省略
  (entmakex
    (append (mapcar 'cons
                    '(0 100 100 43 370 8 62 39 6)
                    (append '("LWPOLYLINE" "AcDbEntity" "AcDbPolyline")
                            (cddr argments)
                    )
            )
            (cons (cons 90 (length (car argments)))
                  (cons        (cons 70
                              (if (cadr argments)
                                (cadr argments)
                                0
                              )
                        )
                        (mapcar '(lambda (x) (cons 10 x)) (car argments))
                  )
            )
    )
  )
)
(defun poinpl (p pt)
  ;;:点是否在指定点表内
  (equal
    (abs
      (apply '+
             (mapcar '(lambda (x y) (rem (- (angle x p) (angle y p)) pi))
                     pt
                     (cons (last pt) pt)
             )
      )
    )
    pi
    1e-8
  )
)
(defun plinexy (e)
  (mapcar 'cdr
          (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget e))
  )
)
(defun SsgetW (arg / a)
  ;;选择指定矩形区域内(不限屏幕范围)
  (ssget "X"
         (apply        'append
                (list '((-4 . "<and") (-4 . ">=,>="))
                      (setq a (list (car arg) (cadr arg))
                            a (mapcar '(lambda (x) (mapcar x a)) '(car cadr))
                            a (mapcar '(lambda (y)
                                         (cons 10 (mapcar '(lambda (x) (apply y x)) a))
                                       )
                                      '(min max)
                              )
                            a (list (car a) '(-4 . "<=,<=") (cadr a))
                      )
                      (cddr arg)
                      '((-4 . "and>"))
                )
         )
  )
)
(defun SsgetCP (arg / a i pt s b)
  ;;根据多线段图元名或者其坐标点表进行(ssget"CP"...)但不限屏幕范围
  (if (listp (setq a (car arg)))
    (setq pt a
          a  (vlax-ename->vla-object (makepl (list pt)))
    )
    (setq pt (plinexy a)
          a  (vlax-ename->vla-object a)
    )
  )
  (if (setq i -1
            s (SsgetW
                (append
                  (mapcar
                    '(lambda (x)
                       (mapcar '(lambda (y) (apply x y))
                               (mapcar '(lambda (x) (mapcar x pt)) '(car cadr))
                       )
                     )
                    '(min max)
                  )
                  (cdr arg)
                )
              )
            s (if (SSMEMB (vlax-vla-object->ename a) s)
                (ssdel (vlax-vla-object->ename a) s)
                s
              )
      )
    (repeat (sslength s)
      (setq i (1+ i)
            e (ssname s i)
      )
      (if
        (not
          (or (> (vlax-safearray-get-u-bound
                   (vlax-variant-value
                     (vla-intersectwith (vlax-ename->vla-object e) a 0)
                   )
                   1
                 )
                 1
              )
              (poinpl (cdr (assoc 10 (entget e))) pt)
          )
        )
         (setq b (cons e b))
      )
    )
  )
  (if (listp (car arg))
    (vla-Delete a)
  )
  (foreach a b (setq s (ssdel a s)))
  s
)
(defun SsgetWP (arg / a i pt s b)
  ;;根据多线段图元名或者其坐标点表进行(ssget"WP"...)但不限屏幕范围
  (if (listp (setq a (car arg)))
    (setq pt a
          a  (vlax-ename->vla-object (makepl (list pt)))
    )
    (setq pt (plinexy a)
          a  (vlax-ename->vla-object a)
    )
  )
  (if (setq i -1
            s (SsgetW
                (append
                  (mapcar
                    '(lambda (x)
                       (mapcar '(lambda (y) (apply x y))
                               (mapcar '(lambda (x) (mapcar x pt)) '(car cadr))
                       )
                     )
                    '(min max)
                  )
                  (cdr arg)
                )
              )
            s (if (SSMEMB (vlax-vla-object->ename a) s)
                (ssdel (vlax-vla-object->ename a) s)
                s
              )
      )
    (repeat (sslength s)
      (setq i (1+ i)
            e (ssname s i)
      )
      (if (or (> (vlax-safearray-get-u-bound
                   (vlax-variant-value
                     (vla-intersectwith (vlax-ename->vla-object e) a 0)
                   )
                   1
                 )
                 1
              )
              (not (poinpl (cdr (assoc 10 (entget e))) pt))
          )
        (setq b (cons e b))
      )
    )
  )
  (if (listp (car arg))
    (vla-Delete a)
  )
  (foreach a b (setq s (ssdel a s)))
  s
)
;以上是复制http://bbs.mjtd.com/forum.php?mo ... 90&page=1#pid881597的代码

;以下修改[start4444]big帮助修改的代码，2020-08-13
(defun c:kn6 (/ ss ss0 s1 ss1 n x ptn)
  (setq ss1 (SsgetCP (list(car (entsel))'(0 . "*") )) ) ;大家可以修改*号为你想要选中的实体类型，SSgetCP改成SSgetWP实现WP选择。
  (sssetfirst nil ss1)
  (princ)
)

masterlong

屏幕外选择函数
本质上是计算图元dxf10组码
是否满足一个确定的CP点集
然而图元和它的dxf10并没有必然联系

比如直线
dxf10是直线的起点
它们是“重合”在一起的
那么代码执行就没有任何问题

而圆弧
dxf10是圆弧的圆心
它和圆弧本身永远都不可能“重合”
甚至可能相差极远
那么代码计算一个圆弧的圆心
处于CP点集范围内
但实际上这个圆弧可能根本不在点集范围内

类似的情况还有块
很多人做块随意性很大
块心离块十万八千里很常见吧

所以这个函数适用面其实非常非常窄

tigcat

masterlong 发表于 2020-12-6 20:55
屏幕外选择函数
本质上是计算图元dxf10组码
是否满足一个确定的CP点集

好的，明白了，谢谢masterlong长老耐心细致的解答，谢谢您！难怪函数有个点的判断。

masterlong

太多人执着于屏幕外选取
现在流行的这个代码
它的使用是有很大限制的
然而写代码和用代码的
都没有考虑那些必须考虑的因素

屏幕缩放保证代码运行正确就这么不可接受么？

tigcat

有很多bug仅是说实现我自己想要的选中有bug，原子函数并无问题。原函数作者不要扔板砖过来

yoyoho

谢谢! tigcat 分享程序!!!!

999999

谢谢楼主分享及其它大神的修改，小弟我试了一下，效果很好，要是能加上框选和可以选择取取的框本身就好了

panliang9

谢谢楼主分享！

zjy2999

谢谢楼主分享！

hncjddd

怎样选取多段线内特定图元

tigcat

hncjddd 发表于 2020-12-4 09:59
怎样选取多段线内特定图元

先选这个多段线，再用选择易。
或者直接修改我提示ssgt 后面的过滤条件。

tigcat

masterlong 发表于 2020-12-3 09:38
太多人执着于屏幕外选取
现在流行的这个代码
它的使用是有很大限制的

您好，请问这个代码有哪些限制呢？