Lisp垃圾表格检查，乱表格检查

admin1

(defun $la-ji-biao-ge-jian-cha$    (ents        rc           lst
                 /        *error*    ents-bhf
                 ents-hx    ents-not   ents-not-cz
                 ents-qx    ents-sx    ents-tai-duan
                 pt-xs-hx   pt-xs-sx   rc
                 ss        x-l-1/5    x-max
                 x-min        y-l-1/5    y-max
                 y-min
                )
  (defun *error* (s) (print))
  (or ents
      (and (SETQ SS (SSGET (LIST (CONS 0 "*LINE"))))
       (setq ents (vl-remove-if
            (function listp)
            (mapcar (function cadr) (ssnamex SS))
              )
       )
      )
  )
  (setq ents-bhf nil)
  (setq ents-hx nil)
  (setq ents-sx nil)
  (setq ents-qx nil)
  (setq ents-not-cz nil)
  (setq ents-tai-duan nil)
  (or rc (setq rc 0.25))
  (mapcar
    (function
      (lambda (a / dxf p1 p2 x-y1-y2 y-x1-x2)
    (setq dxf (entget a))
    (and (setq p1 (cdr (assoc 10 dxf)))
         (setq dxf (vl-remove (assoc 10 dxf) dxf))
    )
    (or (and (setq p2 (cdr (assoc 10 (reverse dxf))))
         (setq dxf (vl-remove (assoc 10 (reverse dxf)) dxf))
        )
        (and (setq p2 (cdr (assoc 11 (reverse dxf))))
         (setq dxf (vl-remove (assoc 11 (reverse dxf)) dxf))
        )
    )
    (cond
      ((equal (car p1) (car p2) rc)
                    ;X相等，说明直线是竖着的
       (setq x-y1-y2 (list a (car p1) (cadr p1) (cadr p2)))
                    ;竖着的直线直接用(X轴、Y1、Y2),竖着的线条，其X轴相等的，所以记录一个X轴，两个Y轴
       (set 'ents-sx (cons x-y1-y2 ents-sx))
      )
      ((equal (cadr p1) (cadr p2) rc)
                    ;Y相等，说明直线是横着的
       (setq y-x1-x2 (list a (cadr p1) (car p1) (car p2)))
                    ;横着的直线直接用(Y轴、X1、X2),横着的线条，其Y轴相等的，所以记录一个Y轴，两个X轴
       (set 'ents-hx (cons y-x1-x2 ents-hx))
      )
      (t (set 'ents-qx (cons a ents-qx)))
                    ;倾斜的线条记录，不合法的线条记录
    )
      )
    )
    ents
  )
  (setq
    pt-xs-hx (APPLY 'APPEND
            (mapcar (function (lambda (a) (cddr a))) ents-hx)
         )
  )                    ;横向直线的所有X坐标
  (setq
    pt-xs-sx (APPLY 'APPEND
            (mapcar (function (lambda (a) (cddr a))) ents-Sx)
         )
  )                    ;横向直线的所有Y坐标
  (SETQ X-MIN (APPLY 'MIN pt-xs-hx))
  (SETQ X-MAX (APPLY 'MAX pt-xs-hx))
  (SETQ Y-MIN (APPLY 'MIN pt-xs-Sx))
  (SETQ Y-MAX (APPLY 'MAX pt-xs-Sx))
  (SETQ X-L-1/5 (/ (ABS (- X-MIN X-MAX)) 5.0))
  (SETQ Y-L-1/5 (/ (ABS (- Y-MIN Y-MAX)) 5.0))
  (setq
    ents-hx
     (MAPCAR
       (FUNCTION
     (LAMBDA (A / X1 X2)
       (setq x1 (caddr a))
       (setq x2 (cadddr a))
       (IF (< (ABS (- X1 X2)) X-L-1/5)
         (progn
           (SET 'ents-tai-duan (cons (car a) ents-tai-duan))
           nil
         )                ;添加到太短记录
         a
       )
     )
       )
       ents-hx
     )
  )
  (setq ents-hx (vl-remove nil ents-hx))
  (setq
    ents-sx
     (MAPCAR
       (FUNCTION
     (LAMBDA (A / y1 y2)
       (setq y1 (caddr a))
       (setq y2 (cadddr a))
       (IF (< (ABS (- y1 y2)) y-L-1/5)
         (progn
           (SET 'ents-tai-duan (cons (car a) ents-tai-duan))
           nil
         )                ;添加到太短记录
         a
       )
     )
       )
       ents-sx
     )
  )
  (setq ents-sx (vl-remove nil ents-sx))
  (mapcar
    (function
      (lambda (a / ent x1 x2 y n czs xs)
    (setq ent (car a))
    (setq y (cadr a))
    (setq x1 (caddr a))
    (setq x2 (cadddr a))
    (setq n 0)
    (setq czs nil)
    (vl-some (function (lambda (b)
                 (and
                   (or (equal (cadr b) x1 rc) ;X轴比一下
                   (equal (cadr b) x2 rc) ;X轴比一下
                   )
                   (set 'czs (cons b czs))
                    ;添加到垂足记录
                   (set 'n (1+ n))
                   (>= n 2)    ;找到两个垂足的就结束循环
                 )
               )
         )
         ents-sx
    )
                    ;(mapcar(function(lambda (a) (vla-put-color (vlax-ename->vla-object a) 6)))czs)
    (setq xs (delsame (mapcar (function (lambda (b) (rtos b 2 1)))
                  (mapcar 'cadr czs)
              )
         )
    );揪出X坐标(这个做法就是防止直线重叠)
    (if (and czs (>= (length xs) 2))
      ()
      (set 'ents-not-cz (cons ent ents-not-cz))
    )
      )
    )
    ents-hx
  )
  (mapcar
    (function
      (lambda (a / ent y1 y2 y n czs ys)
;;;    (if (= (cdr (assoc 5 (entget (car a)))) "259")
;;;      (print)
;;;    )
    (setq ent (car a))
    (setq y1 (caddr a))
    (setq y2 (cadddr a))
    (setq n 0)
    (setq czs nil)
    (vl-some (function (lambda (b)
                 (and
                   (or (equal (cadr b) y1 rc) ;Y轴比一下
                   (equal (cadr b) y2 rc) ;Y轴比一下
                   )
                   (set 'czs (cons b czs))
                    ;添加到垂足记录
                   (set 'n (1+ n))
                   (>= n 2)    ;找到两个垂足的就结束循环
                 )
               )
         )
         ents-hx
    )
                    ;(vla-put-color (vlax-ename->vla-object (CAR A)) 6);(CAR(ENTSEL))
                    ;(mapcar(function(lambda (a) (vla-put-color (vlax-ename->vla-object a) 6)))czs)
    (setq ys (delsame (mapcar (function (lambda (b) (rtos b 2 1)))
                  (mapcar 'cadr czs)
              )
         )
    )                ;揪出Y坐标(这个做法就是防止直线重叠)
    (if (and czs (>= (length ys) 2)) ;Y坐标个数是否大于2
      ()
      (set 'ents-not-cz (cons ent ents-not-cz))
    )
      )
    )
    ents-sx
  )
  (setq
    ents-not
     (vl-remove nil (append ents-qx ents-not-cz ents-tai-duan))
  )
  (mapcar (function
        (lambda (a) (vla-put-color (vlax-ename->vla-object a) 6))
      )
      ents-not
  )
  ents-not
)
;($la-ji-biao-ge-jian-cha$(ssToentlst(SSGET (LIST (CONS 0 "*LINE"))))0.25 nil)
;;;(defun c:tbc () ($la-ji-biao-ge-jian-cha$ nil nil nil)(princ))
;;;(print "垃圾表格检查，快捷键是TBC")