;;;;;;动态弧形标注程序
;;;;;;设计者---jixiangluo
;;;;;;命令:ljx-rdim
;;;;;;要求:在欲标注弧上选取两点,两点必须在同一段弧上
;;;;;;适用于标注:"ARC"、 "CIRCLE"及"LWPOLYLINE"上的圆弧
;;;;;;2019年9月22日最后修改
(defun c:ljx-rdim ( / dim_sc dim_ac dtlst pt1 pt2 pt3 r L Ltxt)
(vl-load-com)
(setq dim_sc (getvar "dimlfac")
dim_ac (getvar "dimdec")
)
(setq dtlst (get-arcpoint))
(setq pt1 (car dtlst)
pt2 (cadr dtlst)
pt3 (nth 2 dtlst)
r (nth 3 dtlst)
L (nth 4 dtlst)
Ltxt (rtos (* L dim_sc) 2 dim_ac)
)
(dyemarcdim pt1 pt2 pt3 Ltxt)
(princ)
)
(defun get-arcpoint ( / pt1 pt2 s1 s2 index emlst1 emlst2 ename get-di em obj pt3 L1 L2 L lst lst1 i ii d1 d2 tj out)
(setq pt1 (getpoint "\n选取园上第一点:")
pt2 (getpoint "\n选取园上第二点:")
)
(setq s1 (ssget "C" pt1 pt1 '((-4 . "<OR") (0 . "ARC") (0 . "CIRCLE") (0 . "LWPOLYLINE") (-4 . "OR>")))
s2 (ssget "C" pt2 pt2 '((-4 . "<OR") (0 . "ARC") (0 . "CIRCLE") (0 . "LWPOLYLINE") (-4 . "OR>")))
index 0
emlst1 '()
emlst2 '()
)
(repeat (max (sslength s1) (sslength s2))
(if (< index (sslength s1))
(setq emlst1 (cons (ssname s1 index) emlst1))
)
(if (< index (sslength s2))
(setq emlst2 (cons (ssname s2 index) emlst2))
)
(setq index (1+ index))
);;;;repeat
(mapcar '(lambda (x) (mapcar '(lambda (y) (if (equal x y) (setq em x))) emlst2)) emlst1)
(if em
(progn
(setq ename (cdr (assoc 0 (entget em)))
get-di vlax-curve-getDistAtPoint
obj (vlax-ename->vla-object em)
)
)
(progn
(alert "\n两点不在同一曲线上")
(exit)
)
)
(cond
((= ename "ARC")
(if (< (get-di obj pt2) (get-di obj pt1))
(setq pt pt1 pt1 pt2 pt2 pt)
)
(setq pt3 (cdr (assoc 10 (entget em)))
r (cdr (assoc 40 (entget em)))
L (- (get-di obj pt2) (get-di obj pt1))
)
)
((= ename "CIRCLE")
(setq r (cdr (assoc 40 (entget em)))
pt3 (cdr (assoc 10 (entget em)))
)
(if (< (get-di obj pt2) (get-di obj pt1));;;;选点时应按逆时针方向
(setq L (- (+ (get-di obj pt2) (* 2 pi r)) (get-di obj pt1)))
(setq L (- (get-di obj pt2) (get-di obj pt1)))
)
)
((= ename "LWPOLYLINE")
(if (< (get-di obj pt2) (get-di obj pt1)) (setq pt pt1 pt1 pt2 pt2 pt))
(setq L1 (get-di obj pt1)
L2 (get-di obj pt2)
L (- L2 L1)
)
(setq lst (ch-lst em (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates obj)))))
(setq i -1)
(setq lst1 (mapcar '(lambda (x) (list (get-di obj x) (vla-getbulge obj (setq i (1+ i))))) lst))
(setq i 0)
(while (< i (1- (length lst1)))
(setq d1 (nth i lst1)
d2 (nth (1+ i) lst1)
)
(if (and (>= L1 (car d1)) (<= L2 (car d2)) (/= (cadr d1) 0))
(progn
(setq ii i tj 1)
(setq pt3 (car (get-ptcr (nth ii lst) (nth (1+ ii) lst) (cadr d1)))
r (cadr (get-ptcr (nth ii lst) (nth (1+ ii) lst) (cadr d1)))
)
(if (< (cadr d1) 0) (setq pt pt1 pt1 pt2 pt2 pt))
)
(setq pt3 nil)
)
(if (= tj 1)
(setq i (1- (length lst1)))
(setq i (1+ i))
)
)
(if (= pt3 nil)
(progn
(alert "\n选择的点不在多义线曲线上")
(exit)
)
)
)
)
(setq out (list pt1 pt2 pt3 r L))
(setq aaa out)
);;;;defun
(defun get-ptcr (p1 p2 td / jj_a jj_a1 se_dance r fwjfe fwjfo p3 out)
(setq jj_a (* (atan td) 4)
jj_a1 (- (/ pi 2) (/ (abs jj_a) 2))
se_dance (distance p1 p2)
r (/ se_dance (* 2 (sin (/ (abs jj_a) 2))))
fwjfe (angle p1 p2)
jj_a1 (abs jj_a1)
)
(cond
((< td 0)
(cond
((<= (abs jj_a) pi)
(setq fwjfo (- fwjfe jj_a1))
)
((> (abs jj_a) pi)
(setq fwjfo (+ fwjfe jj_a1))
)
);cond
)
((> td 0)
(cond
((<= jj_a pi)
(setq fwjfo (+ fwjfe jj_a1))
)
((> jj_a pi)
(setq fwjfo (- fwjfe jj_a1))
)
)
)
)
(setq p3 (polar p1 fwjfo r))
(setq out (list p3 r))
)
(defun ch-lst (ei lsti / ind nn lstn lsti1)
(setq ind 0
nn (if (= (cdr (assoc 0 (entget ei))) "LWPOLYLINE") 2 3)
lstn '()
)
(repeat (/ (length lsti) nn)
(if (= (cdr (assoc 0 (entget ei))) "LWPOLYLINE")
(setq lsti1 (list (nth ind lsti) (nth (1+ ind) lsti) (cdr (assoc 38 (entget ei)))))
(setq lsti1 (list (nth ind lsti) (nth (1+ ind) lsti) (nth (+ 2 ind) lsti)))
)
(setq lstn (cons lsti1 lstn)
ind (+ ind nn)
)
)
(setq lstn (reverse lstn))
)
(defun dyemarcdim (pt1 pt2 pt3 Ltxt)
(setq pt pt2
ang1 (angle pt3 pt2)
ang11 (angle pt2 pt3)
)
(setq lst (entget (entmakex (list '(0 . "DIMENSION") '(100 . "AcDbEntity") '(100 . "AcDbDimension") (cons 10 pt) '(70 . 37) (cons 1 Ltxt)
'(100 . "AcDb3PointAngularDimension") (cons 13 pt1) (cons 14 pt2) (cons 15 pt3)))
)
)
(while (and (setq gr (grread 5)) (= (car gr) 5))
(if (>= (distance pt3 (cadr gr)) (distance pt3 pt2))
(setq ang ang1)
(setq ang ang11)
)
(setq aa (abs (- (angle pt3 pt2) (angle pt3 (cadr gr)))))
(if (> aa pi)
(setq aa (- (* pi 2.0) aa))
)
(setq d (abs (* (- (distance pt3 (cadr gr)) (distance pt3 pt2)) (cos aa))))
(setq pt (polar pt2 ang d))
(entmod (subst (cons 10 pt) (assoc 10 lst) lst))
(entupd (cdr (assoc -1 lst)))
)
)