yjr111大师的两个程序求改编！

theisland

;;;     By  yjr111   http://bbs.mjtd.com/thread-99625-1-1.html
;;; -------------------------------------------------------------------------------------------------------------------
;;;程序1、选中直线或多段线则选中线及在线上的块
;;;目前希望完善的地方：并不是跟直线或PL线相交的所有图块都被选择，只有指定名称的一些图块能被选择。
(defun c:tt1 (/ E PLST SS )
  (setq mycad(vlax-get-acad-object))
  (IF (AND(setq E(car (entsel "\n选择直线或轻多义线: ")))
          (MEMBER (CDR(ASSOC 0(SETQ S(ENTGET E)))) (LIST "LINE" "LWPOLYLINE"))
          )
    (PROGN
       (vla-zoomall mycad)
       (FOREACH X S
        (IF (OR(=(CAR X)10)(=(CAR X)11))
          (SETQ PLST(CONS (CDR X)PLST))
        )
       )
      (setq ss (ssget "F" PLST'((0 . "insert"))))
      (if ss (progn(ssadd E ss)(sssetfirst ss ss))(princ"\n没有块被选中!"))      
    )
  )
  (vla-ZoomPrevious mycad)
  (princ)
)


;;;程序2、选中标注则选中与之相连的所有标注
;;;目前希望完善的地方：目前是只能选择视野范围内的标注，希望屏幕中没有显示的标注也能被选择。
(defun c:tt2 (/ E newss p13 p14 flag newp13 newp14)
  (defun dxf (code ename) (cdr (assoc code (entget ename))))
  (IF (AND (setq E (car (entsel "\n选择标注: ")))
           (eq (dxf 0 e) "DIMENSION")
      )
    (PROGN
      (setq newss (ssadd)oldss (ssadd))
      (ssadd e newss)
      (setq p13        (dxf 13 e)
            p14        (dxf 14 e)
      )
      (lj e p13)
      (setq flag nil)
      (lj e p14)
    )
  )
  (sssetfirst newss newss)
  (princ)
)
(defun lj (jze p / ss n )
  (setq        ss (ssget "c"
                  (mapcar '(lambda (x) (- x (getvar 'pickbox))) p)
                  (mapcar '(lambda (x) (+ x (getvar 'pickbox))) p)
                  '((0 . "dimension"))
           )
  )
  (if ss (ssdel jze ss))
  (if (and ss (> (sslength ss) 0)(not flag))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq ee (ssname ss n))
        (ssadd ee newss)
        (setq n (1+ n))
      )      
      (setq newp13(dxf 13 ee)
            newp14(dxf 14 ee)
      )
      (if (equal newp13 p 1e-1)
        (setq p newp14)
        (setq p newp13)
      )
      (lj ee p)
    )
    (setq flag t)
  )
)

theisland

自己顶起来~

llsheng_73

这个问题并不难，可以自己试着去实现你的想法
第一只需要在ssget后边的过滤表里边加上2组就行
第二个问题要复杂些，ssget"C"的地方需要自己写一个不受显示范围影响的函数来实现（这类例子论坛里边较多），也可以先对屏幕进行缩放后选择，选择完后恢复（这是最简单也很有效和办法）
另外，如果这两个程序都是你自己的，可以直接帮你改了，但是你自己不能一点思路都没有，而这一点比付费或者悬赏更重要！

恒毅

;;;程序1、选中直线或多段线则选中线及在线上的块
;;;目前希望完善的地方：并不是跟直线或PL线相交的所有图块都被选择，只有指定名称的一些图块能被选择。
(defun c:tt1 (/ E PLST SS )
  (setq mycad(vlax-get-acad-object))
        (setq blkname (getstring"\n请输入快名："))
  (IF (AND(setq E(car (entsel "\n选择直线或轻多义线: ")))
          (MEMBER (CDR(ASSOC 0(SETQ S(ENTGET E)))) (LIST "LINE" "LWPOLYLINE"))
          )
    (PROGN
       (vla-zoomall mycad)
       (FOREACH X S
        (IF (OR(=(CAR X)10)(=(CAR X)11))
          (SETQ PLST(CONS (CDR X)PLST))
        )
       )
      (setq ss (ssget "F" PLST (list '(0 . "INSERT") (cons 2 blkname))))
      (if ss (progn(ssadd E ss)(sssetfirst ss ss))(princ"\n没有块被选中!"))      
    )
  )
  (vla-ZoomPrevious mycad)
  (princ)
)

;;;程序2、选中标注则选中与之相连的所有标注
(defun c:tt2 (/ E newss p13 p14 flag newp13 newp14)
  (defun dxf (code ename) (cdr (assoc code (entget ename))))
  (IF (AND (setq E (car (entsel "\n选择标注: ")))
           (eq (dxf 0 e) "DIMENSION")
      )
    (PROGN
                        (setq mycad(vlax-get-acad-object))
                        (vla-ZoomPrevious mycad)
      (setq newss (ssadd)oldss (ssadd))
      (ssadd e newss)
      (setq p13        (dxf 13 e)
            p14        (dxf 14 e)
      )
      (lj e p13)
      (setq flag nil)
      (lj e p14)
                        (vla-ZoomPrevious mycad)
    )
  )
  (sssetfirst newss newss)
  (princ)
)
(defun lj (jze p / ss n )
  (setq        ss (ssget "c"
                  (mapcar '(lambda (x) (- x (getvar 'pickbox))) p)
                  (mapcar '(lambda (x) (+ x (getvar 'pickbox))) p)
                  '((0 . "dimension"))
           )
  )
  (if ss (ssdel jze ss))
  (if (and ss (> (sslength ss) 0)(not flag))
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq ee (ssname ss n))
        (ssadd ee newss)
        (setq n (1+ n))
      )      
      (setq newp13(dxf 13 ee)
            newp14(dxf 14 ee)
      )
      (if (equal newp13 p 1e-1)
        (setq p newp14)
        (setq p newp13)
      )
      (lj ee p)
    )
    (setq flag t)
  )
)

haotaer

高手出手那纯属娱乐。只是热心帮忙

haotaer

谢谢。一定要顶出高手谢谢。一定要顶出高手

437271963

思路：
1.(ssget "X" (list '(0 . "INSERT") (cons 2 blkname)))选择块。
2.取得块的插入点&p1。
3.点选直线或多段线，转换为VLA对象&ob1。
4.(setq &p2 (vlax-curve-getclosestpointto &ob1 &p1));取得最近点。
5.(distance &p1 &p2)求得两点距离。根据距离判断基点是否在线上。

haotaer

谢谢。一定要顶出高手

haotaer

谢谢。一定要顶出高手谢谢。一定要顶出高手

依然小小鸟

不错的帖子 支持一下