半自动坐标标注（含直径，C角）（讨论学习用）

zhouxiuxin

谢谢楼主
正需要

清风明月名字

谢谢分享，学习一下

琴剑江山_10184

老大的太好用啦，居然还可以自动避位

戏男

不错了，有这样的功能 感谢

wayne_myles

有时会标飞怎么回事啊！？请教下

wayne_myles

wayne_myles 发表于 2015-6-25 19:29
有时会标飞怎么回事啊！？请教下

hehe 是的 还有圆的Z -1的话也会飞 不过程序的确不错 谢谢了

瞎捣鼓了下，终于能在zz坐标-1的情况下可以用了 这个只能标注圆直径适合UG转图使用
;自动标注圆直径
(defun C:QQQ (/ dimt dimTad err txtSize s)
     
(vl-Load-com)
  (setq ss (ssget))
  (if ss
    (repeat (setq n (sslength ss))
      (setq obj (vlax-ename->vla-object (ssname ss (setq n (1- n)))))
      (setq ZA (vlax-safearray->list
                 (vlax-variant-value (vla-get-Normal obj))))
      (setq mat        (vlax-tmatrix
                  (list
                    (list 1 0 (car ZA) 0)
                    (list 0 1 (cadr ZA) 0)
                    (list 0 0 (caddr ZA) 0)
                    (list 0 0 0 1)
                    )
                  )
            )
      (vla-TransformBy obj mat)
      )
    )

(setvar "cmdecho" 0) ;指令执行过程不响应
    (setq k (getvar "CLAYER"))
(princ "\n-->请框选要标注的圆.....")
       (KX_dim);KAIXIN自定义标注参数通用函数
  (command "UNDO" "BE")
  (setq dimt (getvar "DIMTMOVE")
dimTad (getvar "DIMTAD")
txtSize (getvar "TEXTSIZE")
s (getvar "DIMSCALE")
  )
  (if (= s 0.0)
    (setq s 1.0)
  )
  (setvar "DIMTMOVE" 0)
  (setvar "DIMTAD" 0)
  (setvar "TEXTSIZE" (* s (getvar "DIMTXT")))
  (setq err (vl-catch-all-apply 'ac-autoDimC nil))
  (if (vl-catch-all-error-p err)
    (progn
      ;; add some error handles here
    )
  )
  (setvar "DIMTMOVE" dimt)
  (setvar "DIMTAD" dimTad)
  (setvar "TEXTSIZE" txtSize)
  (command "UNDO" "E")
     (setvar  "CLAYER" k)
     (PRINC "\n标注圆直径完成！")(PRINC))
;;;
(defun ac-autoDimC(/ ss ent i inf cirPaks arcPaks xs ys x1 x2 y1 y2 cpt newCirPaks newArcPaks)
  (setq ss (ssget)
pt (getpoint "\n-->点击任意地方开始标注: ")
ent (ssname ss 0)
i 0
  )
  (command "UCS" "O" pt)
  (while ent
    (setq inf (ac-dimInfC ent))
    (if inf
      (progn
(cond ((car inf)
        (setq cirPaks (cons (car inf) cirPaks))
       )
       ((cadr inf)
        (setq arcPaks (cons (cadr inf) arcPaks))
       )
)
(setq xs (append (nth 2 inf) xs)
       ys (append (nth 3 inf) ys)
)
      )
    )
    (setq i (1+ i)
   ent (ssname ss i)
    )
  )
  ;; find the center of objects
  (setq x1 (apply 'min xs)
x2 (apply 'max xs)
y1 (apply 'min ys)
y2 (apply 'max ys)
cpt (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0) 0.0)
  )
  ;; dimension
  (setq newCirPaks (ac-reducePaks cirPaks))
  (setq newArcPaks (ac-reducePaks arcPaks))
  (ac-dimCirArc newCirPaks "cir")
  (ac-dimCirArc newArcPaks "arc")
  (command "UCS" "P")
)
;;;
(defun ac-dimInfC(ent / dat p1 p2 ang xs ys inf rad)
  (setq dat (entget ent)
typ (cdr (assoc 0 dat))
  )
  (cond ((= typ "LINE")
  (setq p1  (trans (cdr (assoc 10 dat)) 0 1)
        p2  (trans (cdr (assoc 11 dat)) 0 1)
        xs  (list (car p1) (car p2))
        ys  (list (cadr p1) (cadr p2))
        inf (list nil nil xs ys)
  )
)
((= typ "CIRCLE")
  (setq p1 (trans (cdr (assoc 10 dat)) 0 1)
        rad (cdr (assoc 40 dat))
        xs (list (+ (car p1) rad) (- (car p1) rad))
        ys (list (+ (cadr p1) rad) (- (cadr p1) rad))
  )
  (setq inf (list (list p1 rad ent) nil xs ys))
)
((= typ "ARC")
  (setq p1 (trans (cdr (assoc 10 dat)) 0 1)
        rad (cdr (assoc 40 dat))
        xs (list (+ (car p1) rad) (- (car p1) rad))
        ys (list (+ (cadr p1) rad) (- (cadr p1) rad))
  )
  (setq inf (list nil (list p1 rad ent) xs ys))
)
  )
  inf
)
;;;
(defun ac-dimCirArc(paks typ / pt rad ent rads rTxt sym dec dimEnt txtCen txtBox hv p1 p2 ang stAng wAng obj ang1 len)
  (foreach pak paks
    (setq pt  (nth 0 pak)
   rads (nth 1 pak)
   rad (last rads)
   ent (nth 2 pak)
   dec (getvar "DIMDEC")
   rTxt ""
    )
    (if (= typ "cir")
      (setq sym "%%c")
      (setq sym "R")
    )
    (foreach r (reverse (cdr rads))
      (setq rTxt (strcat ", " sym (rtos (* 2.0 r) 2 dec) rTxt))
    )
    (setq rTxt (strcat sym (rtos (* 2.0 (car rads)) 2 dec) rTxt))
    (if (= typ "cir")
      (progn
(command "DIMDIAMETER" (list ent (polar pt 0.0 rad)) "t" rTxt "none" (polar pt 0.0 rad))
(setq stAng (/ pi 4.0)
       wAng (+ pi 0.01)
)
      )
      (progn
(command "DIMRADIUS" (list ent (polar pt 0.0 rad)) "t" rTxt "none" (polar pt 0.0 rad))
(setq obj (vlax-ename->vla-object ent)
       ang1 (vla-get-startAngle obj)
       len (vla-get-arcLength obj)
       wAng (/ len rad 2.0)
       stAng (+ ang1 wAng)
)
      )
    )
    (setq dimEnt (entlast)
   txtCen (trans (cdr (assoc 11 (entget dimEnt))) 0 1)
   txtBox (textbox (list (cons 1 rTxt)))
   hv (mapcar '(lambda(a b) (/ (- b a) 2.0)) (car txtBox) (cadr txtBox))
   p1 (mapcar '- txtCen hv)
   p2 (mapcar '+ txtCen hv)
    )
    (entdel dimEnt)
    (setq ang (ac-findAng pt p1 p2 stAng wAng (/ pi 16.0)))
    (entdel dimEnt)
    (command "ROTATE" dimEnt "" "none" pt (angtos ang))
  )
)
;;;
(defun ac-reducePaks (paks / pt rad ent infs ptStr inf subPaks newPak newPaks)
  (foreach pak paks
    (setq pt (nth 0 pak)
   rad (nth 1 pak)
   ent (nth 2 pak)
   ptStr (strcat (rtos (car pt) 2 4) "," (rtos (cadr pt) 2 4))
   inf (assoc ptStr infs)
    )
    (if inf
      (setq infs (subst (append inf (list pak)) inf infs))
      (setq infs (cons (list ptStr pak) infs))
    )
  )
  (foreach inf infs
    (setq subPaks (vl-sort (cdr inf) '(lambda(a b) (< (cadr a) (cadr b))))
   newPak (list (caar subPaks) (mapcar 'cadr subPaks) (caddr (last subPaks)))
   newPaks (cons newPak newPaks)
    )
  )
  newPaks
)
;;;
(defun ac-findAng (cen p1 p2 stAng wAng dAng / p3 p4 pts ang ck dir ang2 pts2 ss fAng minS)
  (setq p3  (list (car p1) (cadr p2) 0.0)
p4  (list (car p2) (cadr p1) 0.0)
pts (list p1 p3 p2 p4)
ang 0.0
ck T
  )
  (while ck
    (setq dir T)
    (repeat 2
      (if ck
(progn
   (if dir
     (setq ang2 (+ stAng ang))
     (setq ang2 (- stAng ang))
   )
   (setq pts2 (mapcar '(lambda (a)
    (ac-newPos a cen ang2)
         )
        pts
       )
  dir  (not dir)
  ss   (ssget "cp" pts2)
   )
   (if ss
     (progn
       (if fAng
  (if (< (sslength ss) minS)
    (setq fAng ang2
   minS (sslength ss)
    )
  )
  (setq fAng ang2
        minS (sslength ss)
  )
       )
     ); -progn
     (setq fAng ang2
    ck nil
     )
   ); -if
); -progn
      ); -if
    )
    (if ck
      (setq ang (+ ang dAng)
     ck (<= ang wAng)
      )
    )
  )
  fAng
)
;;;
(defun ac-newPos(pt cen ang / pt2 x1 y1 x2 y2 c s)
  (setq pt2 (mapcar '- pt cen)
x1 (car pt2)
y1 (cadr pt2)
c (cos ang)
s (sin ang)
x2 (- (* x1 c) (* y1 s))
y2 (+ (* x1 s) (* y1 c))
pt2 (mapcar '+ (list x2 y2 0.0) cen)
  )
  pt2
)



(defun KX_dim ()
(command "style" "宋体" "宋体" "0" "1" "0" "" "")
  (command "dimtxt"   "2.5"  "dimasz"   "2"    ; 文字高度：2.5，箭头大小：2
           "dimexe"  "0.5"       "dimexo"   "0.5"    ;尺寸界限超出长度：0.5，尺寸界限起点距离：0.5  
           "dimgap"   "0.5"     "dimtoh"   "off"    ;标注文字周围的距离：0.5，文字在尺寸界线外的位置：关   
           "dimtih"   "OFF"     "blipmode"  "0"    ; 标注文字在尺寸界线内的位置：关，点标记模式：关      
           "DIMDLI"  "5"        "DIMATFIT"  "3"    ; 控制基线标注中尺寸线的间距：5，当尺寸界线不足放下标注文字和箭头时，函数DIMATFIT确定位置
    "DIMTAD"   "0"  "DIMDEC"   "2"    ;控制文字相对尺寸线的垂直位置，小数位数：2        
           "DIMTXSTY"  "宋体"   "DIMCLRT"   "6"    ;指定标注的文字样式：宋体，为标注文字指定颜色：6     
           "DIMJUST"  "0"       "DIMDSEP"  "."    ; 控制标注文字的水平位置：0，小数分隔符为 .  
           "DIMTOFL"  "0"        "dimtmove" "0"    ;控制标注文字在尺寸界线外的位置：关对齐，设置标注文字的移动规则：0 水平
    "dimcen" "0"         "dimclrd" "3"     ;标注圆心：不标，为尺寸线、箭头和标注引线指定颜色：3
           "dimclre" "5"     ;    ;为尺寸界线指定颜色  
   )
(setq layer "标注     dim")(if (not (tblsearch "layer" layer ))
;设图层 判断是否有图层，如果没有建图层
  (progn (command "layer" "new" "标注     dim" "s" "标注     dim" "C" 82 "" "L" "Continuous" "" "LW" 0.09 "" "")
))
     (setvar  "CLAYER" layer)  设标注层为当然层
(princ))

cj52000

怎么才能赚明径币啊，下载不了啊

wang8091

不错啊，，这东西值得大家学习！！！

cooltl18

谢谢分享，学习一下

hnzkhyyl

我也想下载啊，我下了很多的，但是在标注的时候都会飞，怎么让它不飞呢