CASS宗地四至属性批量填入扩展属性
;|;;===========================================================================通用函数 ;
功能：求两个线条对象的交点 ;
适用对象: Line、Circle、Arc、Ellipse、Polyline、 ;
LWPolyline、3dPolyline、Spline ;
参数：OBJ1 ----对象1 ;
OBJ2 ----对象2 ;
Extend ----延伸选项 ;
0acExtendNone ;
1acExtendThisEntity ;
2acExtendOtherEntity ;
3acExtendBoth ;
ZZZ ----输出选项 ;
"=0"Z值取0 ;
"F1"取第一个对象上的点 ;
"F2"取第二个对象上的点 ;
"MAX" 取Z值大者 ;
"MIN" 取Z值小者 ;
Fuzz ----允许偏差值 ;
返回：若成功，返回点位表；否则返回nil
日期：zml84 于2007-11-05
;;|;
(vl-load-com)
(defun ZL-GETINTERS (OBJ1 OBJ2 EXTEND ZZZFUZZ / ENT1
ENT2 PT10 PT11 PT20PT21 OBJ11OBJ22
ARRAYLST LST_PT IPT PT1 PT2
Z1 Z2
)
;;0、对参数的格式化处理
(if (and (= (type EXTEND) 'INT)
(<= 0 EXTEND 3)
)
()
(setq EXTEND 0)
)
(setq ZZZ (strcase ZZZ))
;;======================
;;1、获取交点集合>>>>>>>
(if (and (= (vla-get-objectname OBJ1) "AcDbLine")
(= (vla-get-objectname OBJ2) "AcDbLine")
)
;;对直线对象(line) 特别处理
(progn
(setq ENT1 (entget (vlax-vla-object->ename OBJ1))
ENT2 (entget (vlax-vla-object->ename OBJ2))
)
(setq PT10 (assoc 10 ENT1)
PT11 (assoc 11 ENT1)
PT20 (assoc 10 ENT2)
PT21 (assoc 11 ENT2)
)
;;去除Z坐标
(setq PT10 (list (cadr PT10) (caddr PT10))
PT11 (list (cadr PT11) (caddr PT11))
PT20 (list (cadr PT20) (caddr PT20))
PT21 (list (cadr PT21) (caddr PT21))
)
(setq LST (inters PT10 PT11 PT20 PT21 t))
(if LST
(setq LST (append LST '(0)))
)
)
(progn
;;=====================
;;复制实体
(setq OBJ11 (vla-copy OBJ1)
OBJ22 (vla-copy OBJ2)
)
;;向xy平面投影，将Z坐标改为0
(TOXY OBJ11)
(TOXY OBJ22)
;;获取交点集合
(setq ARRAY (vla-intersectwith OBJ11 OBJ22 EXTEND))
;;删除复制后的对象
(vla-delete OBJ11)
(vla-delete OBJ22)
;;由数组转换为表
(if (and ARRAY
(> (vlax-safearray-get-u-bound
(vlax-variant-value ARRAY)
1
)
1
)
)
(progn
(setq LST (vlax-safearray->list
(vlax-variant-value ARRAY)
)
)
)
)
)
)
;;======================
;;2、分析整理>>>>>>>
(setq LST_PT '())
(if LST
(progn
(setq I 0)
(repeat (/ (length LST) 3)
;;2.1 获取当前点位
(setq PT (list (nth I LST)
(nth (+ 1 I) LST)
(nth (+ 2 I) LST)
)
)
;;2.2 获取对象上对应点位
(setq PT1 (vlax-curve-getclosestpointtoprojection
OBJ1
PT
'(0 0 1)
)
PT2 (vlax-curve-getclosestpointtoprojection
OBJ2
PT
'(0 0 1)
)
)
(setq Z1 (caddr PT1)
Z2 (caddr PT2)
)
;;2.3 效验偏差值
;;就是说：过滤:参数中有偏差值选项，却不满足要求的点位
(if (and FUZZ
(or (= (type FUZZ) 'REAL)
(= (type FUZZ) 'INT)
)
(not (equal Z1 Z2 FUZZ))
)
;; 空处理
()
;;2.4 对输出选项的处理
(progn
(cond
((= ZZZ "F1")
(setq PT PT1)
)
((= ZZZ "F2")
(setq PT PT2)
)
((= ZZZ "MAX")
(if (> Z1 Z2)
(setq PT PT1)
(setq PT PT2)
)
)
((= ZZZ "MIN")
(if (< Z1 Z2)
(setq PT PT1)
(setq PT PT2)
)
)
(t
(setq PT PT)
)
) ;_结束cond
(if (member PT LST_PT)
()
(setq LST_PT (cons PT LST_PT))
)
) ;_结束progn
) ;_结束if
(setq I (+ I 3))
) ;_结束repeat
) ;_结束progn
) ;_结束if
;;3、返回结果>>>>>
LST_PT
) ;_结束defun
;;;============================================================
;;;功能：曲线实体上每个控制点的z坐标值置为0.0
(defun TOXY (OBJ / NAME PT1 TP2)
;;取得实体的类型名称
(setq NAME (vla-get-objectname OBJ))
(cond
;;类型1
;;直线(line)
((= NAME "AcDbLine")
;;取得直线的起终点坐标
(setq PT1 (vlax-variant-value (vla-get-startpoint OBJ))
PT2 (vlax-variant-value (vla-get-endpoint OBJ))
)
;;改变z值为0.0
(vlax-safearray-put-element PT1 2 0.0)
(vlax-safearray-put-element PT2 2 0.0)
(vla-put-startpoint OBJ PT1)
(vla-put-endpoint OBJ PT2)
)
;;类型2
;;圆(circle)
;;圆弧(arc)
;;椭圆及椭圆弧(ellipse)
((or (= NAME "AcDbCircle")
(= NAME "AcDbArc")
(= NAME "AcDbEllipse")
)
;;取得中心点座标
(setq PT1 (vlax-variant-value (vla-get-center OBJ)))
;;改变中心点座标z值为0.0
(vlax-safearray-put-element PT1 2 0.0)
(vla-put-center OBJ PT1)
)
;;类型3
;;多段线(polyline、lwpolyline)
;;拟合的2维多段线(polyline、lwpolyline)
((or (= NAME "AcDbPolyline")
(= NAME "AcDb2dPolyline")
)
;;改变标高值为0.0
(vla-put-elevation OBJ 0.0)
)
;;类型4
;;三维多段线(3dpolyline)
((= NAME "AcDb3dPolyline")
;;取得3维多段线的控制点
(setq PT1 (vlax-variant-value (vla-get-coordinates OBJ))
I 0
)
(repeat (/ (length (vlax-safearray->list PT1)) 3)
(vlax-safearray-put-element PT1 (+ I 2) 0.0)
(setq I (+ I 3))
)
(vla-put-coordinates OBJ PT1)
)
;;类型5
;;样条曲线(Spline)
((= NAME "AcDbSpline")
;;取得样条曲线的拟合点
;;改变每个拟合点的z值为0.0
(setq PT1 (vlax-variant-value (vla-get-fitpoints OBJ))
I 0
)
(repeat (vla-get-numberoffitpoints OBJ)
(vlax-safearray-put-element PT1 (+ I 2) 0.0)
(setq I (+ I 3))
)
(vla-put-fitpoints OBJ PT1)
;;取得样条曲线的控制点
;;改变每个控制点的z值为0.0
(setq
PT2 (vlax-variant-value (vla-get-controlpoints OBJ))
I0
)
(repeat (vla-get-numberofcontrolpoints OBJ)
(vlax-safearray-put-element PT2 (+ I 2) 0.0)
(setq I (+ I 3))
)
(vla-put-controlpoints OBJ PT2)
)
(t NIL)
)
) ;_结束defun
;(setq ppzzxx (ZL-GETINTERS (vlax-ename->vla-object(car (entsel) ) ) (vlax-ename->vla-object(car (entsel) ) ) 0 "f2" nil) )
(defun plinexy(e / p i);;支持lwpolyline和polyline
(setq i -1)
(mapcar(function(lambda(x)(list(car x)(cadr x))))
(repeat(fix(1+(vlax-curve-getEndParam e)))
(setq i(1+ i)p(cons(vlax-curve-getPointAtParam e i)p))))
(reverse(if(equal(car p)(last p))(cdr p)p)))
(defun poinpl(pt p)(equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))
(defun cenpl(e / p o a b c d l)
(setq pl(plinexy e)
p(mapcar'(lambda(x)(/(apply'+(mapcar x pl))(length pl)))'(car cadr))
o(vlax-curve-getClosestPointTo e p)
a(poinpl pl p)d(distance p o)b(if a(angle o p)(angle p o))
q(polar(if a p o)b d))
(while(equal(vlax-curve-getClosestPointTo e q)o 1e-5)
(setq q(polar q b d)))
(mapcar'*'(0.5 0.5)(mapcar'+(vlax-curve-getClosestPointTo e q)o)))
;(entmake (list '(0 . "point") (cons 10 (cenpl (car(entsel)))) ) )
;多边形相对中心
;;;;;;;;;;;;
(defun qlr (e / )
(cdr(nth 3(car(cdr(assoc-3 (entget e '("*")))))))
)
;;;;;;;;;;;;;;;;;;;
(defun mid (p1 p2 /)
(mapcar'(lambda (x y )(* 0.5 (+ x y))) p1 p2 )
)
;;;;;;;;;;;;;;;;;;;
;选择集与对象名表互转
(defun cx-ss2en
(ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
((='ename(type ss))
(ssadd ss)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:sizhi ( / pp i lst lsta entppp pppp ang)
(regapp "DONGZHI")
(regapp "XIZHI")
(regapp "NANZHI")
(regapp "BEIZHI")
(setq i 0)
(setq lst (ssget "x"'( (0 . "*line") (8 . "jzd")) ) )
(repeat (sslength lst)
(setq ent (ssname lst i))
(setq lsta (ssget "x"'( (0 . "*line")(8 . "jzd") ) ) )
(foreach x (cx-ss2en lsta)
;;;;;
(if (and(/= (equal ent x) t)
(setq pp(ZL-GETINTERS (vlax-ename->vla-object ent ) (vlax-ename->vla-object x ) 0 "f2" nil))
(>= (length pp) 2)
(setq ppp(cenpl ent))(setq pppp(cenpl x))(setq ang (angle ppp pppp))
)
(progn(cond( (or(and (>= ang (* 1.75 pi)) (<= ang (* 2.00 pi)) ) (and (>= ang (* 0 pi)) (<= ang (* 0.25 pi)) )) (entmod(subst (append (assoc-3 (entget ent '("*")) ) (list (list "DONGZHI" (cons 1000 (qlr x)))) ) (assoc-3 (entget ent '("*")) )(entget ent '("*"))) ))
( (and (>= ang (* 1.25 pi)) (<= ang (* 1.75 pi)) ) (entmod(subst (append (assoc-3 (entget ent '("*")) ) (list (list "NANZHI" (cons 1000 (qlr x)))) ) (assoc-3 (entget ent '("*")) )(entget ent '("*"))) ))
((and (>= ang (* 0.75 pi)) (<= ang (* 1.25 pi)) )(entmod(subst (append (assoc-3 (entget ent '("*")) ) (list (list "XIZHI" (cons 1000 (qlr x)))) ) (assoc-3 (entget ent '("*")) )(entget ent '("*"))) ))
((and (>= ang (* 0.25 pi)) (<= ang (* 0.75 pi)) ) (entmod(subst (append (assoc-3 (entget ent '("*")) ) (list (list "BEIZHI" (cons 1000 (qlr x)))) ) (assoc-3 (entget ent '("*")) )(entget ent '("*"))) ))
)
)
)
;;;;;;;;((* 0.75 pi)<=(angle ppp pppp)<=(* 1.25 pi) )
)
(setq i (+ i 1))
)
)
本帖最后由 树櫴希德 于 2016-10-1 16:50 编辑
<div class="blockcode"><blockquote>(defun offsetpt(pt d flag / m n pi2 d1 p1 p0 p q0 q2 q22 q1 q pt1 pt2);|falg 0闭合点表，1不闭合它;d<0向内>0向外(假定它有内外)
pt内少于2个点坐标时不处理，直接返回原表，两个点时会根据D的正负而偏移方向不同|;
(defun PlDir(p / n m p1 p2 p3 o a a1 a2)
(defun PoInPl(pt p / n i va ang);;该过程由 StEf44604813提供，本人只是把输出由原来的t,nil改为了-1,0,1
(setq n(length pt)
pt(append pt(list(car pt)))i 0 ang 0)
(while(< i n)
(setq va(-(angle p(nth i pt))(angle p(nth(1+ i)pt))))
(if (<(abs(-(abs va)pi))0.000001)(setq ang 2 i n)
(progn(cond((> va pi)(setq va (- va pi)))
((< va (* -1 pi))(setq va (+ va pi))))
(setq ang(+ ang va)i(1+ i)))))
(if(= ang 2)0
(if(<(abs(-(abs ang) pi))0.000001)1 -1))
);defun
(setq n(length p)pi2(* pi 2)m 2 p1(nth 0 p)p2(nth 1 p))
(while(< m n)
(setq p3(nth m p)
o(list(/(+(+(car p1)(car p2))(car p3))3)(/(+(+(cadr p1)(cadr p2))(cadr p3))3))
m(if(<(PoInPl p o)1)n(1+ m))))
(setq a(angle o p1) a1(-(angle o p2)a)
a1(if(< a1 0)(+ a1 pi2)a1)
a2(-(angle o p3)a)
a2(if(< a2 0)(+ a2 pi2)a2)
m(if(> a1 a2)t))
);defun
(setq m(length pt)
fx(if(> m 2)(PlDir pt)t) pt2(if fx (reverse pt)pt) n
flag d1(abs d)
pi15(*(if(> d 0)1 -1)(* pi 1.5)))
(while(< n(- m flag))
(cond((< m 2)(setq pt1 pt2))
((>= m 2)(setq p(nth n pt2)
p0(if(<(1- n)0)(last pt2)(nth(1- n)pt2))
p1(if(=(1+ n)m)(car pt2)(nth(1+ n)pt2))
n(1+ n)
ang1(+(angle p0 p)pi15)
ang2(+(angle p p1)pi15))
(setq q0(polar p0 ang1 d1)
q2(polar p ang1 d1)
q22(polar p ang2 d1)
q1(polar p1 ang2 d1)
q(inters q0 q2 q22 q1 nil))))
(if(= m 2)(setq pt1(list q0 q2))
(progn (if(=(* flag n)2) (setq pt1(append pt1(list q0))))
(setq pt1(append pt1(list q)))
(if(=(* flag n)(- m flag))
(setq pt1(append pt1(list q1)))))
)
)
(if fx(reverse pt1)pt1)
)
;(setq ppzzxx (ZL-GETINTERS (vlax-ename->vla-object(car (entsel) ) ) (vlax-ename->vla-object(car (entsel) ) ) 0 "f2" nil) )
(defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点
(setq a(vlax-ename->vla-object e)
q(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates a)))
m(vla-get-objectname a)a 0
m(if(= m"AcDb3dPolyline")3 2))
(repeat(/(length q)m)
(cond((= m 2)(setq p1(list(nth a q)(nth(+ a 1)q))))
((= m 3)(setq p1(list(nth a q)(nth(+ a 1)q)(nth(+ a 2)q)))))
(setq p(if (member p1 p)p (append p(list p1)))
a(+ a m)))
p)
(defun poinpla(pt p)(equal(abs(apply'+(mapcar'(lambda(x y)(rem(-(angle x p)(angle y p))pi))pt(cons(last pt)pt))))pi 1e-8))
(defun cenpl(e / p o a b c d l)
(setq pl(plinexy e)
p(mapcar'(lambda(x)(/(apply'+(mapcar x pl))(length pl)))'(car cadr))
o(vlax-curve-getClosestPointTo e p)
a(poinpla pl p)d(distance p o)b(if a(angle o p)(angle p o))
q(polar(if a p o)b d))
(while(equal(vlax-curve-getClosestPointTo e q)o 1e-5)
(setq q(polar q b d)))
(mapcar'*'(0.5 0.5)(mapcar'+(vlax-curve-getClosestPointTo e q)o)))
;(entmake (list '(0 . "point") (cons 10 (cenpl (car(entsel)))) ) )
;多边形相对中心
;;;;;;;;;;;;
(defun qlr (e / )
(cdr(nth 3(car(cdr(assoc-3 (entget e '("*")))))))
)
;;;;;;;;;;;;;;;;;;;
(defun mid (p1 p2 /)
(mapcar'(lambda (x y )(* 0.5 (+ x y))) p1 p2 )
)
;;;;;;;;;;;;;;;;;;;
;选择集与对象名表互转
(defun cx-ss2en
(ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
((='ename(type ss))
(ssadd ss)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;
;(reverse lst)
(defun c:sizhi ( / pp i lst lsta entppp pppp ang d pt11)
(regapp "DONGZHI")
(regapp "XIZHI")
(regapp "NANZHI")
(regapp "BEIZHI")
(setq d(getreal"\n查找偏移距离<0向内,>0向外:"))
(setq i 0)
(setq lst (ssget "x"'( (0 . "lwpolyline") (8 . "jzd")) ) )
(repeat (sslength lst)
(setq ent (ssname lst i))
(setq pt1(offsetpt (plinexy ent) d 0))
(setq lsta (ssget "cp" pt1 '( (0 . "lwpolyline")(8 . "jzd") ) ) )
(if (= lsta nil) (progn (setq pt1(offsetpt (reverse(plinexy ent)) d 0)) (setq lsta (ssget "cp" pt1 '( (0 . "lwpolyline")(8 . "jzd") ) ) ) ) )
(foreach x (cx-ss2en lsta)
;;;;;
(if (and(/= (equal ent x) t)
;(setq pp(ZL-GETINTERS (vlax-ename->vla-object ent ) (vlax-ename->vla-object x ) 0 "f2" nil))
;(>= (length pp) 2)
(setq ppp(cenpl ent))(setq pppp(cenpl x))(setq ang (angle ppp pppp))
)
(progn(cond( (or(and (>= ang (* 1.75 pi)) (<= ang (* 2.00 pi)) ) (and (>= ang (* 0 pi)) (<= ang (* 0.25 pi)) )) (entmod(subst (append (assoc-3 (entget ent '("*")) ) (list (list "DONGZHI" (cons 1000 (qlr x)))) ) (assoc-3 (entget ent '("*")) )(entget ent '("*"))) ))
( (and (>= ang (* 1.25 pi)) (<= ang (* 1.75 pi)) ) (entmod(subst (append (assoc-3 (entget ent '("*")) ) (list (list "NANZHI" (cons 1000 (qlr x)))) ) (assoc-3 (entget ent '("*")) )(entget ent '("*"))) ))
((and (>= ang (* 0.75 pi)) (<= ang (* 1.25 pi)) )(entmod(subst (append (assoc-3 (entget ent '("*")) ) (list (list "XIZHI" (cons 1000 (qlr x)))) ) (assoc-3 (entget ent '("*")) )(entget ent '("*"))) ))
((and (>= ang (* 0.25 pi)) (<= ang (* 0.75 pi)) ) (entmod(subst (append (assoc-3 (entget ent '("*")) ) (list (list "BEIZHI" (cons 1000 (qlr x)))) ) (assoc-3 (entget ent '("*")) )(entget ent '("*"))) ))
)
)
)
;;;;;;;;((* 0.75 pi)<=(angle ppp pppp)<=(* 1.25 pi) )
)
(setq i (+ i 1))
)
)
(vl-load-com)
(initget 2)
;(setq getds (getdist "\n输入偏移距离<可直接量取>:"))
(setq d(getreal"\n查找偏移距离<0向内,>0向外:"))
(setq i 0)
(setq lst (ssget "x"'( (0 . "lwpolyline") (8 . "jzd")) ) )
(repeat (sslength lst)
(setq ent (ssname lst i))
(vla-offset (vlax-ename->vla-object ent) d)
(setq lsta (ssget "cp" (plinexy (entlast)) '( (0 . "lwpolyline") (8 . "jzd")) ) )
(if (= lsta nil)(progn (entdel (entlast)) (vla-offset (vlax-ename->vla-object ent) (* -1 d))
(setq lsta (ssget "cp" (plinexy (entlast)) '( (0 . "lwpolyline") (8 . "jzd")) ) ) ))
(entdel (entlast)) 没注释的程序看着累..我的也没注释,过段时间自己都看不懂. 同意楼上的说法
一点都看不懂
页:
[1]