G版你以前的程序看下，竖向的能不能弄下呀

664571221

;;选择对角点连线 ，By 明经通道 Gu_xl 2012.09.14
(defun c: DJLX  (/             PTINBOX           P1          P2         MINX        MINY   MAXX
              MAXY   SS            PL           N          EN         EL        PT     VERTEX
              PTS    DumpPoint)
  (defun ptinbox  (p mi_x mi_y ma_x ma_y)
    (and (>= (car p) mi_x)
         (>= (cadr p) mi_y)
         (<= (car p) ma_x)
         (<= (cadr p) ma_y)
         )
    )
  (defun DumpPoint  (ptLst fuzz / pt1 x)
    (cond ((<= (length ptLst) 1) ptLst)
          (t
           (setq pt1 (car ptLst))
           (cons pt1
                 (vl-remove-if
                   '(lambda (x) (equal pt1 x fuzz))
                   (DumpPoint (cdr ptLst) fuzz))
                 )
           ))
    )
  (while (and
           (setq p1 (getpoint "\n第一点: "))
           (setq p2 (getcorner p1 "\n对角点: "))
           )
    (setq minx (min (car p1) (car p2))
          miny (min (cadr p1) (cadr p2))
          maxx (max (car p1) (car p2))
          maxy (max (cadr p1) (cadr p2))
          )
    (setq ss (ssget "c" p1 p2 '((0 . "line,*polyline"))))
    (if        ss
      (progn
        (setq pl nil)
        (repeat        (setq n (sslength ss))
          (setq en (ssname ss (setq n (1- n))))
          (cond
            ((= "LINE" (cdr (assoc 0 (setq el (entget en)))))
             (if (ptinbox (setq pt (cdr (assoc 10 el)))
                          minx
                          miny
                          maxx
                          maxy)
               (setq pl (cons (list (car pt) (cadr pt)) pl))
               (if (ptinbox (setq pt (cdr (assoc 11 el)))  
                            minx
                            miny
                            maxx
                            maxy)
                 (setq pl (cons (list (car pt) (cadr pt))pl))
                 )
               )
             )
            ((= "LWPOLYLINE" (cdr (assoc 0 el)))
             (mapcar '(lambda (a)
                        (if (ptinbox (cdr a) minx miny maxx maxy)
                          (setq pl (cons (cdr a) pl))))
                     (vl-remove-if '(lambda (x) (/= 10 (car x))) el)
                     )
             )
            (t
             (setq vertex
                    (vlax-safearray->list
                      (vlax-variant-value
                        (vla-get-Coordinates
                          (vlax-ename->vla-object en)
                          )
                        )
                      )
                   pts nil
                   )
             (while vertex
               (if
                 (ptinbox
                   (setq pt (list (car vertex) (cadr vertex)))
                   minx
                   miny
                   maxx
                   maxy)
                  (setq pl (cons pt pl))
                  )
               (setq vertex (cdddr vertex))


               )
             )
            )
          )


        (setq pl (DumpPoint pl 1e-6)
              pl (vl-sort pl
                          '(lambda (a b)
                             (if (= (cadr a) (cadr b))
                               (< (car a) (car b))
                               (> (cadr a) (cadr b))
                               )
                             )
                          )
              )
        (while (setq p1        (car pl)
                     p2        (cadr pl)
                     )
          (entmake (list '(0 . "line")
                         '(62 . 1)
                         (cons 10 p1)
                         (cons 11 p2)
                         )
                   )
          (setq pl (cddr pl))
          )




        )
      )
    )
  (princ)
  )

Gu_xl

修改这句代码即可：
(setq pl (DumpPoint pl 1e-6)
              pl (vl-sort pl
                          '(lambda (a b)
                             (if (= (cadr a) (cadr b))
                               (< (car a) (car b))
                               (> (cadr a) (cadr b))
                               )
                             )
                          )
              )
==》

1. (setq pl (DumpPoint pl 1e-6)
   
2.               pl (vl-sort pl
   
3.                           '(lambda (a b)
   
4.                              (if (= (car a) (car b))
   
5.                                (> (cadr a) (cadr b))
   
6.                                (< (car a) (car b))
   
7.                                )
   
8.                              )
   
9.                           )
   
10.               )

(setq pl (DumpPoint pl 1e-6)<br />               pl (vl-sort pl<br />                           '(lambda (a b)<br />                              (if (= (car a) (car b))<br />                                (> (cadr a) (cadr b))<br />                                (< (car a) (car b))<br />                                )<br />                              )<br />                           )<br />               )

664571221

Gu_xl 发表于 2018-7-11 16:50
修改这句代码即可：
(setq pl (DumpPoint pl 1e-6)
              pl (vl-sort pl

非常感谢g版