- ;;[功能] 判断多段线自交
- ;;自贡黄明儒 2014.11.24(HH_LWPOLYLINEInters (car(entsel)))
- (defun HH_LWPOLYLINEInters (e / E0 I P PTS)
- (setq pts (Entity:Box e))
- (setq p (mapcar '- (car pts) '(2 2)))
- (setq pts (list p (cadr pts)))
- (setq p (mapcar '+ (car pts) '(1 1)))
- (setvar "nomutt" 1)
- (setq e0 (entlast))
- (APPLY 'Make-Rectange pts)
- (APPLY 'command (list "BOUNDARY" p))
- (while (not (equal (getvar "cmdnames") "")) (apply 'command (list "")))
- (setvar "nomutt" 0)
- (cond ((entnext e0)
- (setq i 0)
- (while (setq e (entnext e0)) (setq i (1+ i)) (entdel e))
- (> i 1)
- )
- )
- )
- ;;[功能] 实体包围盒2角点
- (defun Entity:Box (obj / bp up)
- (cond ((equal (type obj) 'ENAME) (setq obj (vlax-ename->vla-object obj))))
- (vla-getboundingbox obj 'bp 'up)
- (list (safearray-value bp) (safearray-value up))
- )
- ;;164.30 [功能] 构造矩形 by highflybird
- (defun Make-Rectange (pt1 pt2)
- (entmake
- (list
- '(0 . "LWPOLYLINE") ;轻多段线
- '(100 . "AcDbEntity")
- '(100 . "AcDbPolyline")
- '(90 . 4) ;四个顶点
- '(70 . 1) ;闭合
- ;;(cons 38 (caddr pt1)) ;高程
- (cons 10 (list (car pt1) (cadr pt1))) ;左下角
- (cons 10 (list (car pt2) (cadr pt1))) ;右下角
- (cons 10 (list (car pt2) (cadr pt2))) ;右上角
- (cons 10 (list (car pt1) (cadr pt2))) ;左上角
- (cons 210 '(0 0 1)) ;法线方向
- )
- )
- )
|