[讨论]：如何找到多义线的对角点

啵浪鼓

谢谢各位，程序可行啦！
不过依然有个小问题，下面的需要再改良一下，在分析时，可能会取到侧视图的数值
              (if (and (and (< (car bp) (car bp0))
                            (< (cadr bp) (cadr bp0))
                       )
                       (and (> (car up) (car up0))
                            (> (cadr up) (cadr up0))
                       )
                  )
                (setq outpl   e
                      out_box (list bp up)
                )

eachy

你最好从作图规则上解决，否则程序要没有意义的增加很多。程序怎么判断是主视图？

啵浪鼓

CNS国标三视图的原则是一主视图二侧视图，（主视图内包含长与宽是程序需要找到的，另二侧视图通常为下侧视图及右侧视图，31楼图片中我只画了下侧视图，右侧视图未画出）

程序是否可以将（if （and。。。这段写得更明了一点，可以通过以下几点判断：
一种可能：
主视图的长=下侧视图的长
主视图的宽>下侧视图的高
另一种可能：
主视图的长>右视图的高
主视图的宽=右视图的宽

eachy

增加矩形中心点的判断，当相等时X最小，Y最大

啵浪鼓

if这段我这样写，找到对角点得最大值留下，排除最小的对角点，结果还是一样，不知怎写了，斑竹能否再指点一下？          
   (if (and (and (< (car bp) (car bp0))
      (< (cadr bp) (cadr bp0))
      )
     (and (> (car up) (car up0))
             (> (cadr up) (cadr up0))
     )
     (> (distance bp up) (distance bp0 up0)) ;;;此句为新加
     )

eachy

返回最左上角实体的BOX点

2. (defun getssoutpl (ss / ssl e bp up bp_lst ptl)
   
3.   (setq ssl (sslength ss))
   
4.   (while (> ssl 0)
   
5.     (setq e (ssname ss (setq ssl (1- ssl))))
   
6.     (vla-getboundingbox (vlax-ename->vla-object e) 'bp 'up)
   
7.     (setq bp (safearray-value bp)
   
8.           up (safearray-value up)
   
9.     )
   
10.     (setq bp_lst (cons bp bp_lst)
    
11.           ptl         (cons (list bp up) ptl)
    
12.     )
    
13.   )
    
14.   (if bp_lst
    
15.     (progn
    
16.       (setq bp_lst (vl-sort bp_lst
    
17.                             '(lambda (e1 e2)
    
18.                                (if (equal (cadr e1) (cadr e2) 0.00001)
    
19.                                   (< (car e1) (car e2))
    
20.                                   (> (cadr e1) (cadr e2))
    
21.                                )
    
22.                              )
    
23.                    )
    
24.       )
    
25.       (assoc (car bp_lst) ptl)
    
26.     )
    
27.   )
    
28. )
    
29. (defun c:tt (/ ss box)
    
30.   (if (setq ss (ssget))
    
31.     (progn
    
32.       (setq box (getssoutpl ss))
    
33.       (command ".line" (car box) (cadr box) "")
    
34.     )
    
35.   )
    
36. )

(defun getssoutpl (ss / ssl e bp up bp_lst ptl)<br />   (setq ssl (sslength ss))<br />   (while (> ssl 0)<br />     (setq e (ssname ss (setq ssl (1- ssl))))<br />     (vla-getboundingbox (vlax-ename->vla-object e) 'bp 'up)<br />     (setq bp (safearray-value bp)<br />           up (safearray-value up)<br />     )<br />     (setq bp_lst (cons bp bp_lst)<br />           ptl         (cons (list bp up) ptl)<br />     )<br />   )<br />   (if bp_lst<br />     (progn<br />       (setq bp_lst (vl-sort bp_lst<br />                             '(lambda (e1 e2)<br />                                (if (equal (cadr e1) (cadr e2) 0.00001)<br />                                   (< (car e1) (car e2))<br />                                   (> (cadr e1) (cadr e2))<br />                                )<br />                              )<br />                    )<br />       )<br />       (assoc (car bp_lst) ptl)<br />     )<br />   )<br /> )<br /> (defun c:tt (/ ss box)<br />   (if (setq ss (ssget))<br />     (progn<br />       (setq box (getssoutpl ss))<br />       (command ".line" (car box) (cadr box) "")<br />     )<br />   )<br /> )

xyp1964

所谓“多义线的对角点”到底指的是那两个点？

eachy

Box

xyp1964

最初由 eachy 发布
[B]返回最左上角实体的BOX点
[code](defun getssoutpl (ss / ssl e bp up bp_lst ptl)
  (setq ssl (sslength ss))
  (while (> ssl 0)
    (setq e (ssname ss (setq ssl (1- ssl))))
    (vla-getboundingbox (v... [/B]

(defun c:tt (/ ss box)
  (if (setq ss (ssget))
    (progn
      (setq box (getssoutpl ss))
      (command ".line" (car box) (cadr box) "")
    )
  )
)
……
程序对(ssget)选集不产生作用，只能对其中的一条多义线生成box顶点连线。

啵浪鼓

36楼程序还是不行，找到里面的坐标。
如图所示，排除里面的聚合线，排除下面的聚合线，红线的对角才是我想要的（只要是选中的聚合线我只要最大的聚合线对角点就好了）

29楼的程序很好了，只是不能取大舍小，为何斑竹不是在原有基础上改良呢？
以下是29楼eachy斑竹编写的原贴：
(defun c:tt (/           p1         p2    s1    s2           s3         s4    s5    s6
             s7           s8         s9    s10   s11   s12         s13   box1  box2
             box3  box4         box5  box6  box7  box8         box9  box10 box11
             box12 box13 oldos getssoutpl
            )
  (defun getssoutpl (ss / ssl e outpl out_box bp up bp0 up0)
    (if        ss
      (progn
        (setq ssl (sslength ss))
        (while (> ssl 0)
          (setq e (ssname ss (setq ssl (1- ssl))))
          (vla-getboundingbox (vlax-ename->vla-object e) 'bp 'up)
          (if (not outpl)
            (setq outpl          e
                  out_box (list (safearray-value bp) (safearray-value up))
            )
            (progn
              (vla-getboundingbox (vlax-ename->vla-object e) 'bp 'up)
              (setq bp        (safearray-value bp)
                    up        (safearray-value up)
                    bp0        (car out_box)
                    up0        (cadr out_box)
              )
              (if (and (and (< (car bp) (car bp0))
                            (< (cadr bp) (cadr bp0))
                       )
                       (and (> (car up) (car up0))
                            (> (cadr up) (cadr up0))
                       )
                  )
                (setq outpl   e
                      out_box (list bp up)
                )
              )
            )
          )
        )
      )
    )
    out_box
  )
  (if (setq tk (entsel "\nPick TK: "))
    (progn
      (setq oldos (getvar "osmode"))
      (setvar "osmode" 0)
      (setvar "cmdecho" 0)
      (setq obj (vlax-ename->vla-object (car tk)))
      (vla-getboundingbox obj 'tk_bp 'tk_up) ;_ 求对角点
      (setq tk_bp (safearray-value tk_bp) ;_ 转换
            tk_up (safearray-value tk_up) ;_ 转换
      ) ;_注意UCS
      (setq midp (polar        tk_bp
                        (angle tk_bp tk_up)
                        (/ (distance tk_bp tk_up) 2)
                 )
      ) ;_图框中心
      ;;测试 Box 是否在屏幕内，不在则缩放并记录最后恢复
      (command ".zoom" "o" tk "") ;_ 2005以上功能, 缩放实体至适合屏幕
      (setq oldos (getvar "osmode"))
      (setvar "osmode" 0)
      (setvar "cmdecho" 0)
      ;;(command ".zoom" "w" tk_bp tk_up);_
      (setq d1        (ssget "w" tk_bp tk_up '((8 . "D01A")))
            d2        (ssget "w" tk_bp tk_up '((8 . "D02A")))
            d3        (ssget "w" tk_bp tk_up '((8 . "D03A")))
            d4        (ssget "w" tk_bp tk_up '((8 . "D04A")))
            d5        (ssget "w" tk_bp tk_up '((8 . "D05A")))
            d5B        (ssget "w" tk_bp tk_up '((8 . "D05B")))
            s1        (ssget "w" tk_bp tk_up '((8 . "S01A")))
            s1b        (ssget "w" tk_bp tk_up '((8 . "S01B")))
            s2        (ssget "w" tk_bp tk_up '((8 . "S02A")))
            p5        (ssget "w" tk_bp tk_up '((8 . "P05A")))
            p4        (ssget "w" tk_bp tk_up '((8 . "P04A")))
            p3        (ssget "w" tk_bp tk_up '((8 . "P03A")))
            p2        (ssget "w" tk_bp tk_up '((8 . "P02A")))
            p1        (ssget "w" tk_bp tk_up '((8 . "P01A")))
      )
      (setq box1  (getssoutpl d1)
            box2  (getssoutpl d2)
            box3  (getssoutpl d3)
            box4  (getssoutpl d4)
            box5  (getssoutpl d5)
            box6  (getssoutpl d5b)
            box7  (getssoutpl s1)
            box8  (getssoutpl s1b)
            box9  (getssoutpl s2)
            box10 (getssoutpl p5)
            box11 (getssoutpl p4)
            box12 (getssoutpl p3)
            box13 (getssoutpl p2)
            box13 (getssoutpl p1)
      )
      ;;测试对角点
      (mapcar '(lambda (a)
                 (if a
                   (command ".line" (car a) (cadr a))
                 )
               )
              (list box1 box2 box3 box4        box5 box6 box7 box8 box9 box10
                    box11 box12        box13)
      )
      ;;后面是你自己的处理程序
      (setvar "osmode" oldos)
    )
  )
  (princ)
)

xyp1964

楼上的图形是矩形，太特殊，应该比较容易实现。

思路：将所有多义线的顶点生成列表，取出最小x和y坐标值组成左下角点，取出最大x和y坐标值组成右上角点。[/COLOR]

eachy

最初由 啵浪鼓 发布
[B]36楼程序还是不行，找到里面的坐标。
如图所示，排除里面的聚合线，排除下面的聚合线，红线的对角才是我想要的（只要是选中的聚合线我只要最大的聚合线对角点就好了）

29楼的程序很好了，只是不能取大舍小，为何... [/B]

新写的不是里面套用的，仅适合几个分开的。

啵浪鼓

哦，我还以为斑竹在承前启后帮我写如何取大舍小呢，呵呵~

eachy

最左上角的取大舍小

2. 
   
3. (defun getssoutpl (ss / ssl e out_box bp up)
   
4.   (if ss
   
5.     (progn
   
6.       (setq ssl (sslength ss))
   
7.       (while (> ssl 0)
   
8.         (setq e (ssname ss (setq ssl (1- ssl))))
   
9.         (vla-getboundingbox (vlax-ename->vla-object e) 'bp 'up)
   
10.         (if (not out_box)
    
11.           (setq
    
12.             out_box (list (safearray-value bp) (safearray-value up))
    
13.           )
    
14.           (progn
    
15.             (vla-getboundingbox (vlax-ename->vla-object e) 'bp 'up)
    
16.             (setq bp (safearray-value bp)
    
17.                   up (safearray-value up)
    
18.             )
    
19.             (if        (and (>= (cadr up) (cadadr out_box))
    
20.                      (<= (car bp) (caar out_box))
    
21.                 )
    
22.               (setq out_box (list bp up))
    
23.             )
    
24.           )
    
25.         )
    
26.       )
    
27.     )
    
28.   )
    
29.   out_box
    
30. )

<br /> (defun getssoutpl (ss / ssl e out_box bp up)<br />   (if ss<br />     (progn<br />       (setq ssl (sslength ss))<br />       (while (> ssl 0)<br />         (setq e (ssname ss (setq ssl (1- ssl))))<br />         (vla-getboundingbox (vlax-ename->vla-object e) 'bp 'up)<br />         (if (not out_box)<br />           (setq<br />             out_box (list (safearray-value bp) (safearray-value up))<br />           )<br />           (progn<br />             (vla-getboundingbox (vlax-ename->vla-object e) 'bp 'up)<br />             (setq bp (safearray-value bp)<br />                   up (safearray-value up)<br />             )<br />             (if        (and (>= (cadr up) (cadadr out_box))<br />                      (<= (car bp) (caar out_box))<br />                 )<br />               (setq out_box (list bp up))<br />             )<br />           )<br />         )<br />       )<br />     )<br />   )<br />   out_box<br /> )

xyp1964

多义线顶点坐标连线和最小包围外框：
[php]
(load "xyp_lib");加载通用函数
;|
如果已经下载xyp_lib并放到搜索路径下可以不再下载!
利用以下任何一种方式即可加载和运行通用函数内的所有子程序：
1.在acad.lsp中增加(load"xyp_lib")
2.在每个程序内增加(load"xyp_lib")
3.在command下，输入(load"xyp_lib")
4.在菜单.mnl中增加(load"xyp_lib")
通用函数下载地址：http://www.xdcad.net/forum/showthread.php?s=&threadid=325268
|;

;;;多义线顶点坐标连线和最小包围外框(框选)
(defun c:test123 ()
  (cmdla0)
  (princ "\n选取PLINE多义线...")
  (setq        ss    (ssget '((0 . "*POLYLINE")))
        i     0
        ptlst '()
  )
  (repeat (sslength ss)
    (setq ssn        (ssname ss i)
          coord        (vla-get-Coordinates (vlax-ename->vla-object ssn))
          n        0
    )
    (repeat
      (/ (length (vlax-safearray->list (vlax-variant-value coord))
         )
         2
      )
       (setq ptx   (vlax-safearray-get-element (vlax-variant-value coord) n)
             n           (1+ n)
             pty   (vlax-safearray-get-element (vlax-variant-value coord) n)
             n           (1+ n)
             pt           (list ptx pty)
             ptlst (cons pt ptlst)
       )
    )
    (setq i (+ 1 i))
  )
;;;
  (setq        pt-minx         (vl-sort ptlst
                          (function (lambda (e1 e2)
                                      (< (car e1) (car e2))
                                    )
                          )
                 )
        pt-miny         (vl-sort ptlst
                          (function (lambda (e1 e2)
                                      (< (cadr e1) (cadr e2))
                                    )
                          )
                 )
        pt-max-x (vl-sort ptlst
                          (function (lambda (e1 e2)
                                      (> (car e1) (car e2))
                                    )
                          )
                 )
        pt-max-y (vl-sort ptlst
                          (function (lambda (e1 e2)
                                      (> (cadr e1) (cadr e2))
                                    )
                          )
                 )
        pt1         (list
                   (car (car pt-minx))
                   (cadr (car pt-miny))
                 )
        pt2         (list
                   (car (car pt-max-x))
                   (cadr (car pt-max-y))
                 )
  )
  (mkla "外框" 1)
  (command "line" pt1 pt2 "")
  (command "rectang" pt1 pt2)
  (cmdla1)
)[/php]