TA的每日心情![](source/plugin/dsu_paulsign/img/emot/kx.gif) | 开心 2024-8-31 15:58 |
---|
签到天数: 89 天 [LV.6]常住居民II
管理员
- 积分
- 3366
|
(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") |
|