(defun EF:Style-getAllTextStyles (
/
TextStyles lstFonts
Typeface Bold Italic CharSet PitchAndFamily
)
(setq TextStyles (Vlax-Get (Vlax-Get (Vlax-Get-Acad-Object) 'ActiveDocument) 'TextStyles))
(vlax-for TextStyle TextStyles
(vla-getFont TextStyle 'Typeface 'Bold 'Italic 'CharSet 'PitchAndFamily)
(setq lstFonts (cons
(list
(vla-get-Name TextStyle)
(vla-get-FontFile TextStyle)
(vla-get-BigFontFile TextStyle)
Typeface
(vla-get-Height TextStyle)
(vla-get-Width TextStyle)
(vla-get-ObliqueAngle TextStyle)
)
lstFonts
)
)
)
(reverse lstFonts)
)
;;167.7 [功能] Entmake居中单行文字
(defun EntmakeText (PT STR Textheigh style)
(entmakeX
(list '(0 . "TEXT")
(cons 1 str)
(cons 10 pt)
(cons 40 Textheigh)
(cons 11 pt)
(cons 7 style)
(cons 72 1)
(cons 73 2)
)
)
)
(setq i 0)
(foreach a (EF:Style-getAllTextStyles)
(EntmakeText (getpoint"\n请点击位置：") "区123" 30 (car a))
(setq i (1+ i)) (print i)
)
(princ)
;(nth 20 (EF:Style-getAllTextStyles))
(defun PoInPl(pt lst / i p1 p2 an anl ret)
(setq i -1 p1 (last lst))
(while(and(not ret)(setq p2(nth(setq i(1+ i))lst)))
(cond((equal p2 pt 1e-6)(setq ret t))
(t(setq an(-(angle pt p1)(angle pt p2)))
(if(equal pi(abs an) 1e-6)
(setq ret t)
(setq anl(cons(rem an PI)anl)))))
(setq p1 p2))
(cond(ret 0);线上;
(t(if(equal PI(abs(apply'+ anl))1e-6)1 -1))))
(defun PlDir(p / n m p1 p2 p3 o a a1 a2)
(setq n(length p)pi2(+ pi pi)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 o p)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 Plinexy(e / p a b n ob q et d d1 en et)
(setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
(cond((="LWPOLYLINE"et)
(repeat(length a)(setq b (nth n a) n (+ n 1))
(if (= 10 (car b))(progn
(setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
(if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
(setq p (list q)))))))
((="POLYLINE"et)
(SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
(WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
(SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
(if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
(SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
(setq p(reverse p))))P)
(defun midlstnm(n m lst / a lst1)
(setq a 0)
(vl-member-if'(lambda(x)(if(<= n(setq a(1+ a))m)(setq lst1 (cons x lst1)))(if(> a m)t))lst)
(reverse lst1))
(defun cdrnlst(n lst / a nlst)
(setq a 0)
(if(< n(length lst))(setq nlst(vl-member-if'(lambda(x)(setq a (1+ a))(< n a))lst)))
nlst)
(defun clockwise(pt / a i)
(setq a(list(eval(cons'min(mapcar'car pt)))(eval(cons'max(mapcar'cadr pt))))
a(cdar(vl-sort(mapcar'(lambda(x)(cons(distance x a)x))pt)(function(lambda(x y)(<(car x)(car y))))))
i(vl-position a pt)
pt(append(cdrnlst i pt)(midlstnm 0 i pt))))
(defun modplver(e pt / e2);;将多线段顶点坐标改为PT所定义的点
(setq e(entget e)e2(member(assoc 90 e)e))
(foreach x e2(setq e(vl-remove x e)))
(setq e(append e(list(cons 90 (length pt))(assoc 70 e2)))
e(if(assoc 43 e2)(append e(list(assoc 43 e2))))
e(if(assoc 38 e2)(append e(list(assoc 38 e2))))
e(if(assoc 39 e2)(append e(list(assoc 39 e2))))
e2(member(assoc 10 e2)e2))
(foreach x(mapcar'(lambda(x)(list(car x)(cadr x)))pt)
(setq e(append e(list(cons 10 x)(cadr e2)(caddr e2)'(42 . 0)))e2(cddddr e2)))
(entmod e))
(defun c:tt()
(setq e(car(entsel)))
(setq pt(plinexy e))
(setq pt(if(pldir pt)pt(reverse pt)));;如果pt不是顺时针方向将其反向
(modplver e(clockwise pt));;将pt(clockwise pt)的起点调整为西北角
)
大发程序啊！ (setq bn (strcat (menucmd "M=$(edtime,$(getvar,date),YYYYMODDhhmmss)")))
页:
1
[2]