定制的任意点标高标注源码分享。。请各位大师查下有没错谢谢
定制的任意点标高标注源码分享。。请各位大师查下有没错谢谢(defun ebox (e / pa pb)
(Vlax-Invoke-Method (Vlax-Ename->Vla-Object e ) 'GetBoundingBox 'pa 'pb )
(setq pa (trans (vlax-safearray->list pa) 0 1)
pb (trans (vlax-safearray->list pb) 0 1)
)
(list pa pb)
)
(defun mid (p1 p2) (mapcar (function (lambda (e1 e2) (* (+ e1 e2) 0.5))) p1 p2))
(defun cbox (e / box p1 p2)
(setq box (ebox e)
p1 (car box)
p2 (cadr box)
)
(mid p1 p2)
)
(defun mktext (la str pt th ang sca)
(entmakex (list '(0 . "TEXT")
(cons 8 la)
(cons 1 str)
(cons 10 pt)
(cons 40 th)
(cons 50 ang)
(cons 41 sca)
(cons 11 pt)
(cons 71 0)
(cons 72 1)
(cons 73 1)
)
)
)
(defun dxf (key ename) (cdr (assoc key (entget ename))))
(defun ss2lst ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
)
)
)
(defun geo:scale (pt pbase k)
(mapcar (function (lambda (u v) (+ u (* k (- v u))))) pbase pt);
)
(defun plane:perpendicular_foot (p p1 p2 p3 / f a b c d h n l)
(setq f (plane:equation_3p p1 p2 p3))
(setq a (car f)
b (cadr f)
c (caddr f)
d (last f)
)
(setq h (plane:distance p a b c d))
(setq n (list a b c))
(setq l (distance '(0 0 0) n))
(if (not (zerop l))
(list h (geo:scale (mapcar '+ p n) p (- (/ h l))))
)
)
(defun plane:distance (P A B C D)
(if (and (zerop A) (zerop B) (zerop C))
nil
(/ (+ (* A (car P)) (* B (cadr P)) (* C (caddr P)) D)
(distance '(0 0 0) (list A B C))
)
)
)
(defun plane:equation_3p (p0 p1 p2 / v1 v2 n)
(setq v1 (mapcar '- p1 p0))
(setq v2 (mapcar '- p2 p0))
(setq n(mat:vxv v1 v2))
(plane:equation p0 n)
)
(defun plane:equation (p0 n)
(append n (list (- (mat:dot p0 n))))
)
(defun mat:dot (v1 v2)
(apply '+ (mapcar '* v1 v2))
)
(defun mat:vxv ( u v )
(list
(- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
(- (* (carv) (caddr u)) (* (caru) (caddr v)))
(- (* (caru) (cadrv)) (* (carv) (cadru)))
)
)
(defun line:colinearity (p1 p2 p3 / a b c eps)
(setq eps 1e-6)
(setq a (distance p2 p3))
(setq b (distance p3 p1))
(setq c (distance p1 p2))
(or (equal (+ a b) c eps)
(equal (+ b c) a eps)
(equal (+ c a) b eps)
)
)
(defun ntfd (lst / a la lb x)
(setq lb nil)
(while lst
(setq a (caddar lst)
la (vl-remove-if-not '(lambda(x) (equal a (caddr x) 1e-6)) lst)
lst (vl-remove-if '(lambda(x) (equal a (caddr x) 1e-6)) lst)
lb (cons la lb)
)
)
(reverse lb)
)
(defun delsame (l) (if l (cons (car l) (delsame (vl-remove-if '(lambda ( x ) (equal (caar l) (car x) 1e-6)) l)))))
(defun qnx (l n)
(if (and l (< 0 n))
(append (list (car l)) (qnx (cdr l) (1- n)))
)
)
(defun n3p1 (pt pl / a b x)
(setq pl (vl-sort pl '(lambda (a b) (< (distance (qnx a 2) pt) (distance (qnx b 2) pt))))
pl (qnx pl 4)
pl (ntfd pl)
pl (mapcar '(lambda(x) (car (vl-sort x '(lambda (a b) (< (distance (qnx a 2) pt) (distance (qnx b 2) pt)))))) pl)
pl (qnx pl 3)
)
)
(defun ssbox ( s / a b i m n o )
(repeat (setq i (sslength s))
(if
(and
(setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
(vlax-method-applicable-p o 'getboundingbox)
(not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
)
(setq m (cons (vlax-safearray->list a) m)
n (cons (vlax-safearray->list b) n)
)
)
)
(if (and m n)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
)
)
(defun mkpline (pts cl)
(entmakex (append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length pts))
(if cl
(cons 70 1)
(cons 70 0)
)
)
(mapcar '(lambda (a) (cons 10 a)) pts)
)
)
)
(defun mkline (pt1 pt2) (entmakex (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2))))
(defun ayOSMode (isOpenSnap)
(if isOpenSnap
(setvar "osmode" (rem (getvar "osmode") 16384))
(setvar "osmode" (+ (rem (getvar "osmode") 16384) 16384))
)
)
(defun str2lst ( str del / pos )
(if (setq pos (vl-string-search del str))
(cons (substr str 1 pos) (str2lst (substr str (+ pos 1 (strlen del))) del))
(list str)
)
)
(defun lst0n (l n)
(if (and l (< 0 n))
(append (list (car l)) (lst0n (cdr l) (1- n)))
)
)
(defun sw (el) (mapcar 'append el (cdr el) ) )
(defun c:tt ( / bn dd en gcfw l1 la lfw ll lss lst msg odlst p ss th txt x y)
(vl-load-com)
(defun *error*(msg)
(mapcar 'setvar '("cmdecho" "osmode") odlst)
(princ msg)
(exit)
)
(setq odlst (mapcar 'getvar '("cmdecho" "osmode")))
(setvar "cmdecho" 0)
(setq en (car (entsel "\n选取标高块:"))
gcfw (getstring "输入高程范围以英文逗号分隔[最低,最高]");如
lfw (vl-sort (str2lst gcfw ",") '(lambda (x y) (< x y) ) )
lfw (mapcar 'atof lfw)
bn (dxf 2 en)
la (dxf 8 en)
th (getreal "\n输入字高:")
)
(print "\n选择处理范围内的全部标高块:")
(setq ss (ssget ":S" (list '(0 . "INSERT") (cons 2 bn) (cons 8 la))))
(if ss
(progn
(setq lss (ss2lst ss)
ll (mapcar '(lambda(x) (dxf 10 x)) lss)
ll (vl-remove-if-not '(lambda(x) (> (cadr lfw) (caddr x) (car lfw))) ll)
)
(while (and (ayOSMode t) (setq p (getpoint "\n图面取点:")))
(setq l1 (n3p1 p ll)
dd (plane:perpendicular_foot p (car l1) (cadr l1) (caddr l1))
txt (mktext "高程标注" (rtos (last (cadr dd)) 2 3) p th 0 0.75)
)
(entmakex (list '(0 . "INSERT") (cons 2 bn) (cons 10 (cadr dd))))
)
)
)
(mapcar 'setvar '("cmdecho" "osmode") odlst)
)
(defun c:tt1 ( / a b bn box d e en h i l1 l2 la lb ll lss lx odlst p1 p2 pa pb pc ss sse str w x y)
(vl-load-com)
(setq odlst (mapcar 'getvar '("cmdecho" "osmode")))
(mapcar 'setvar '("cmdecho" "osmode") '(0 0))
(setq en (car (entsel "\n选取标高块:")))
(print "\n框选或点选高程文本:")
(setq ss (ssget '((0 . "TEXT")))
box (ssbox ss)
pa (car box)
pb (cadr box)
bn (dxf 2 en)
ll nil
)
(mapcar 'set '(w h) (mapcar '- pb pa))
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i)))
d (* 2 (dxf 40 e))
pc (cbox e)
str (* 1e3 (abs (atof (dxf 1 e))))
p1 (mapcar '- (car box) (list d d))
p2 (mapcar '+ (cadr box) (list d d))
sse (ssget "c" p1 p2 (list '(0 . "INSERT") (cons 2 bn)))
)
(if sse
(setq lss (ss2lst sse)
lss (if (> (length lss) 1) (vl-sort lss '(lambda (x y) (< (distance (cbox x) pc) (distance (cbox y) pc)))) lss)
a (car lss)
p1 (dxf 10 a)
ll (cons (list p1 str) ll)
)
)
)
(if (> w h)
(setq ll (vl-sort ll '(lambda (x y) (< (caar x) (caar y))))
l2 (mapcar 'cadr ll)
l1 (sw ll)
l1 (mapcar '(lambda(x) (cons (distance (car x) (caddr x)) (- (cadddr x) (cadr x)))) l1)
i 0
l1 (mapcar '(lambda(x)
(setq lx (lst0n l1 (setq i (1+ i)))
la (apply '+ (mapcar 'car lx))
lb (apply '+ (mapcar 'cdr lx))
)
(list la lb)
) l1)
l1 (append (list pa) (mapcar '(lambda (x) (mapcar '+ x pa)) l1))
a (mapcar '- (car l1) (list 0 (car l2)))
b (mapcar '- (last l1) (list 0 (last l2)))
l1 (append (list a) l1 (list b))
a (mkpline l1 t)
)
(setq ll (vl-sort ll '(lambda (x y) (< (cadar x) (cadar y))))
l2 (mapcar 'cadr ll)
l1 (sw ll)
l1 (mapcar '(lambda(x) (cons (distance (car x) (caddr x)) (- (cadddr x) (cadr x)))) l1)
i 0
l1 (mapcar '(lambda(x)
(setq lx (lst0n l1 (setq i (1+ i)))
la (apply '+ (mapcar 'car lx))
lb (apply '+ (mapcar 'cdr lx))
)
(list la lb)
) l1)
l1 (append (list pb) (mapcar '(lambda (x) (mapcar '+ x pb)) l1))
a (mapcar '- (car l1) (list 0 (car l2)))
b (mapcar '- (last l1) (list 0 (last l2)))
l1 (append (list a) l1 (list b))
a (mkpline l1 t)
)
)
(mapcar 'setvar '("cmdecho" "osmode") odlst)
)
(print "\n tt图面插入高程点,tt1框选生成断面!")
(print) 各位路过的兄弟麻烦给查下用这个插件标注在图上的标高有没有错谢谢 你用原来自己的方法抽算几个点不就行了.... 虽然不在同一行业，但是我力挺楼主！ 好厉害啊啊啊啊 树櫴希德 发表于 2015-3-6 14:26
好厉害啊啊啊啊
兄弟你也是这方面高手能否帮忙…检查下…这个代码所标注的标高是否有错误的地方麻烦了谢谢 虽然不在同一行业，但是我力挺楼主！ 难道没有高手愿意帮忙核对下标高有没有错吗... 用不了…… xyp1964 发表于 2015-3-6 20:00 static/image/common/back.gif
用不了……
能用啊啊啊啊呀
页:
[1]
2