立即注册 登录
晓东CAD家园-论坛 返回首页

ljxkm的个人空间 http://bbs.xdcad.net/?769669 [收藏] [复制] [分享] [RSS]

日志

动态弧形标注

已有 93 次阅读2019-9-29 11:29 |个人分类:程序源码| 动态弧形标注程序

;;;;;;动态弧形标注程序
;;;;;;设计者---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)))
  )
)

路过

雷人

握手

鲜花

鸡蛋

全部作者的其他最新日志

评论 (0 个评论)

facelist doodle 涂鸦板

您需要登录后才可以评论 登录 | 立即注册

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-3-29 14:08 , Processed in 0.207016 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

返回顶部