[炫翔]--{元旦礼物}---批量半径驱动圆,圆弧中心线(源码)

炫翔 · 发表于 2013-12-31 13:12:26

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

本帖最后由炫翔于 2013-12-31 13:15 编辑

(defun c:xx ( / co enlst i p1 p2 r r1 s1 ss sss x)
(coma)
(xx-princa "批量半径驱动圆,圆弧中心线")
(xx-princ "圆,圆弧对象")
(xx-ax-load-ltypes '("center"))
(mapcar 'xx-setv '("osmode" "celtype" "cecolor" "celtscale") '(0 "center" "1" 1000))
(setq r (xx-dist "新半径" r 10))
(setq ss (ssget '((0 . "arc,circle"))))
(setq i (sslength ss))
(while (setq s1 (ssname ss (setq i (1- i))))
(setq co (xx-get-dxf 10 s1))
(setq r1 (xx-get-dxf 40 s1))
(setq p1(mapcar '+ co '(1 1))
p2(mapcar '- co '(1 1))
)
(if(setq sss(ssget "f" (list p1 p2) '((0 . "line"))))
(progn
(setq enlst(xx-ss-enlst sss))
(foreach x enlst
(if(equal(xx-curve-mid x)co 0.001)
(vl-cmdf "_.erase" (list x (getvar "viewctr")) "")
)
)
(xx-put-dxf s1 40 r)
(xx-mk-cir co r)
)
(progn
(xx-put-dxf s1 40 r)
(xx-mk-cir co r)
)
)
)
(comb)
)
;画中心线
(defun xx-mk-cir (co r1 / p1 p2 p3 p4 rr)
(setq rr (+ r1 (* 0.1 r1)))
(setq p1 (polar co (* pi 0.5) rr)
p2 (polar co (* 1.5 pi) rr)
p3 (polar co pi rr)
p4 (polar co 0 rr)
)
(xx-mk-line p1 p2)
(xx-put-dxf (entlast) 48 r1)
(xx-mk-line p3 p4)
(xx-put-dxf (entlast) 48 r1)
)
(defun xx-mk-line (p1 p2)
(entmake(list '(0 . "line")(cons 10 p1)(cons 11 p2)))
)
(defun xx-put-dxf (ss code new / ent i s1 tp)
(setq tp (type ss))
(cond
((= tp 'ENAME);判断是否是图元
(setq ent (entget ss))
(if (and (= (type code) 'list) (= (type new) 'list));判断是否是表
(mapcar (function (lambda (x y) (xx-put-dxf ss x y))) code new);表循环取得每个表值，并替换更新
(progn
(if (= (xx-get-dxf code ss) nil);为空时
(entmod (append ent (list (cons code new))));替换为原来的（不变）
(entmod (subst (cons code new) (assoc code ent) ent));替换成新的对象
)
(entupd ss);更新对象
)
)
)
((= tp 'PICKSET);判断是否是选择集
(setq i -1)
(while (setq s1 (ssname ss (setq i (1+ i))))
(xx-put-dxf s1 code new)
)
)
((= tp 'list);判断是否是表
(foreach x ss (xx-put-dxf x code new));循环递归到更新
)
(t (princ "\n xx-put-dxf 错了！"))
)
ss
)
(defun xx-get-dxf (code s1 / ent lst)
(if (= (type code) 'list);判断是否是表
(progn
(setq ent(entget s1);提取串列
lst '();设表为空
)
(foreach a code ;利用foreach函数循环提取表中各值
(setq lst (cons (list a (cdr(assoc a ent))) lst));表中串列以后循环加入表
)
(reverse lst);将表的元素顺序倒置后返回
)
(if (= code -3)
(cdr(assoc code (entget s1 '("*"))));提取扩展数据
(cdr(assoc code (entget s1)))
)
)
)
(defun xx-dist (msg def chushi / inp)
(if (= def nil) (setq def chushi))
(setq msg (strcat "\n->请确定" msg "(或直接点两点量取) <" (rtos def) ">:"))
(setq inp(getdist msg))
(if inp inp def)
)
(defun xx-Curve-Mid (curve / d)
(setq d (* (vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve)) 0.5))
(vlax-curve-getPointAtDist curve d)
)
(defun xx-ss-EnLst (ss / e el i)
(setq i (sslength ss))
(while (setq e (ssname ss (setq i (1- i))))
(setq el (cons e el))
)
el
)
(defun xx-ax-load-Ltypes ( lts / aclin XX-Str-Feng-Zhi)
(defun XX-Str-Feng-Zhi (Str del / pos lst)
(while (setq pos (vl-string-search del str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ pos 1 (strlen del)))
)
)
(if (= " " Del)
(vl-remove "" (reverse (cons str lst)))
(reverse (cons str lst))
)
)
(setq aclin
(apply 'append
(mapcar '(lambda ( directory ) (vl-directory-files directory "*.lin" 1))
(XX-Str-Feng-Zhi ;将具有分隔符的字符串解析为列表
(vla-get-SupportPath (vla-get-Files (vla-get-Preferences (xx-acad)))) ";"
)
)
)
)
(apply 'and
(mapcar
(function
(lambda ( lt )
(or (tblsearch "LTYPE" lt)
(vl-some
(function
(lambda ( lin )
(vl-catch-all-apply 'vla-load
(list (vla-get-linetypes (vla-get-activedocument (xx-acad)))lt lin)
)
(tblsearch "LTYPE" lt)
)
)
aclin
)
)
)
)
lts
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;程序开始
(defun coma()
(if (> (atof (getvar "acadver")) 15.)
(vl-load-com)
)
(xx-VlaPu);用VLA选集时事先清理
(xx-StartUndo);标记开始
(setq *x-r* *error*
*error* *x-er*
)
t
)
;设变量
;(xx-setv "osmode" 0)
(defun xx-setv (name value / odv)
(setq odv (getvar name))
(if (not (assoc name *syl*));判断是否有
(setq *syl* (append *syl* (list (cons name odv))))
)
(setvar name value)
odv
)
;程序结束
(defun comb ()
(xx-unsetvars)
(setq *error* *x-r*)
(xx-EndUndo);标记结束
(princ)
)
;错误处理
(defun *x-er*(msg)
(if(and msg (/= msg "Function cancelled"))
(prompt (strcat "Error: " msg))
(princ)
)
(comb)
(princ)
)
;还原变量
(defun xx-unsetvars ()
(foreach v *syl* (setvar (car v) (cdr v)))
)
;标记开始
(defun xx-StartUndo ()
(vla-startundomark (xx-doc))
)
;标记结束
(defun xx-EndUndo nil
(vla-endundomark (xx-doc))
)
;CAD对象
(defun xx-acad nil
(eval (list 'defun 'xx-acad 'nil (vlax-get-acad-object)))
(xx-acad)
)
;当前激活的文档
(defun xx-doc nil
(eval (list 'defun 'xx-doc 'nil(vla-get-activedocument (xx-acad))))
(xx-doc)
)
;清除前一选择集
(defun xx-VlaPu (/ x)
(if(not(vl-catch-all-error-p(setq x(vl-catch-all-apply 'vla-item
(list (vla-get-selectionsets (vla-get-activedocument (xx-acad))) "CURRENT")))))
(vla-delete x)
)
(princ)
)
;程序开头用
;(xx-princA txt);txt为要显示的部分内容例如:(xx-princA "坐标标注")
;字符用了表转字符串，再用字符串转表的方法
(defun xx-princA (txt)
(princ
(strcat
(vl-list->string '(10 161 190 236 197 207 232 67 65 68 178 229 188 254 161 191 45 45 45))
txt
(vl-list->string '(185 166 196 220 32))
(vl-list->string '(32 32 32 81 81 58 50 51 54 51 54 55 51 53 51 52))
)
)
)
;命令行显示
;(xx-princ txt);txt为要显示功能
(defun xx-princ (txt)
(princ (strcat "\n-->请确定" txt ":"))
(princ)
)
;程序结束用
;(xx-princB txt1 txt2);txt1为要显示功能 txt2为要显示命令
;(xx-princB "标注" "AD")
;字符用了表转字符串，再用字符串转表的方法
(defun xx-princB (txt1 txt2 / txt)
(princ
(strcat
(vl-list->string '(10 161 190 236 197 207 232 67 65 68 178 229 188 254 161 191 45 45 45 185 166 196 220 58))
txt1
(vl-list->string '(44 40 195 252 193 238 58))
txt2
(vl-list->string '(41 44 215 247 213 223 58 161 190 236 197 207 232 161 191 163 172 81 81 58 50 51 54 51 54 55 51 53 51 52))
)
)
(princ)
)
(princ)

(defun c:xx ( / co enlst i p1 p2 r r1 s1 ss sss x) 
  (coma) 
  (xx-princa "批量半径驱动圆,圆弧中心线") 
  (xx-princ "圆,圆弧对象") 
  (xx-ax-load-ltypes '("center")) 
  (mapcar 'xx-setv '("osmode" "celtype" "cecolor"  "celtscale") '(0 "center" "1" 1000)) 
  (setq r (xx-dist "新半径" r 10)) 
  (setq ss (ssget '((0 . "arc,circle")))) 
  (setq i (sslength ss)) 
  (while (setq s1 (ssname ss (setq i (1- i)))) 
    (setq co (xx-get-dxf 10 s1)) 
    (setq r1 (xx-get-dxf 40 s1)) 
    (setq p1(mapcar '+ co '(1 1)) 
          p2(mapcar '- co '(1 1)) 
    ) 
    (if(setq sss(ssget "f" (list p1 p2) '((0 . "line")))) 
     (progn 
       (setq enlst(xx-ss-enlst sss)) 
       (foreach x enlst 
         (if(equal(xx-curve-mid x)co 0.001) 
          (vl-cmdf "_.erase" (list x (getvar "viewctr")) "") 
         ) 
       ) 
       (xx-put-dxf s1 40 r) 
       (xx-mk-cir co r) 
      ) 
      (progn 
       (xx-put-dxf s1 40 r) 
       (xx-mk-cir co r) 
      ) 
     ) 
    ) 
 (comb) 
) 
 
;画中心线 
(defun xx-mk-cir (co r1 / p1 p2 p3 p4 rr) 
  (setq rr (+ r1 (* 0.1 r1))) 
  (setq p1 (polar co (* pi 0.5) rr) 
  p2 (polar co (* 1.5 pi) rr) 
  p3 (polar co pi rr) 
  p4 (polar co 0 rr) 
  ) 
  (xx-mk-line p1 p2) 
  (xx-put-dxf (entlast) 48 r1) 
  (xx-mk-line p3 p4) 
  (xx-put-dxf (entlast) 48 r1) 
) 
(defun xx-mk-line (p1 p2) 
 (entmake(list '(0 . "line")(cons 10 p1)(cons 11 p2))) 
) 
 
(defun xx-put-dxf (ss code new / ent i s1 tp) 
    (setq tp (type ss)) 
  (cond 
    ((= tp 'ENAME);判断是否是图元 
       (setq ent (entget ss)) 
     (if (and (= (type code) 'list) (= (type new) 'list));判断是否是表 
       (mapcar (function (lambda (x y) (xx-put-dxf ss x y))) code new);表循环取得每个表值，并替换更新 
      (progn 
        (if (= (xx-get-dxf code ss) nil);为空时 
          (entmod (append ent (list (cons code new))));替换为原来的（不变） 
          (entmod (subst (cons code new) (assoc code ent) ent));替换成新的对象 
        ) 
       (entupd ss);更新对象 
      ) 
     ) 
    ) 
   ((= tp 'PICKSET);判断是否是选择集 
      (setq i -1) 
    (while (setq s1 (ssname ss (setq i (1+ i)))) 
       (xx-put-dxf s1 code new) 
    ) 
   ) 
   ((= tp 'list);判断是否是表 
    (foreach x ss (xx-put-dxf x code new));循环递归到更新 
   ) 
   (t (princ "\n xx-put-dxf  错了！")) 
  ) 
 ss 
) 
 
(defun xx-get-dxf (code s1 / ent lst) 
  (if (= (type code) 'list);判断是否是表 
    (progn 
      (setq ent(entget s1);提取串列 
            lst '();设表为空 
      ) 
      (foreach a code ;利用foreach函数循环提取表中各值 
        (setq lst (cons (list a (cdr(assoc a ent))) lst));表中串列以后循环加入表 
      ) 
      (reverse lst);将表的元素顺序倒置后返回 
    ) 
    (if (= code -3)   
      (cdr(assoc code (entget s1 '("*"))));提取扩展数据 
      (cdr(assoc code (entget s1))) 
    ) 
   ) 
) 
 
(defun xx-dist (msg def chushi / inp) 
  (if (= def nil) (setq def chushi)) 
  (setq msg (strcat "\n->请确定" msg "(或直接点两点量取) <" (rtos def) ">:")) 
  (setq inp(getdist msg)) 
  (if inp inp def) 
) 
 
(defun xx-Curve-Mid (curve / d) 
  (setq d (* (vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve)) 0.5)) 
  (vlax-curve-getPointAtDist curve d) 
) 
(defun xx-ss-EnLst (ss / e el i) 
  (setq i (sslength ss)) 
  (while (setq e (ssname ss (setq i (1- i)))) 
    (setq el (cons e el)) 
  ) 
  el 
) 
(defun xx-ax-load-Ltypes ( lts / aclin XX-Str-Feng-Zhi) 
 (defun XX-Str-Feng-Zhi (Str del / pos lst) 
      (while (setq pos (vl-string-search del str)) 
  (setq lst (cons (substr str 1 pos) lst) 
        str (substr str (+ pos 1 (strlen del))) 
  ) 
      ) 
      (if (= " " Del) 
  (vl-remove "" (reverse (cons str lst))) 
  (reverse (cons str lst)) 
      ) 
 ) 
  (setq aclin 
    (apply 'append 
      (mapcar '(lambda ( directory ) (vl-directory-files directory "*.lin" 1)) 
        (XX-Str-Feng-Zhi  ;将具有分隔符的字符串解析为列表 
          (vla-get-SupportPath (vla-get-Files (vla-get-Preferences (xx-acad)))) ";" 
        ) 
      ) 
    ) 
  ) 
  (apply 'and 
    (mapcar 
      (function 
        (lambda ( lt ) 
          (or (tblsearch "LTYPE" lt) 
            (vl-some 
              (function 
                (lambda ( lin ) 
                  (vl-catch-all-apply 'vla-load 
                   (list (vla-get-linetypes (vla-get-activedocument (xx-acad)))lt lin) 
                   ) 
                 (tblsearch "LTYPE" lt) 
                ) 
              ) 
              aclin 
            ) 
          ) 
        ) 
      ) 
      lts 
    ) 
  )   
) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;程序开始 
(defun coma() 
 (if (> (atof (getvar "acadver")) 15.) 
   (vl-load-com) 
 ) 
  (xx-VlaPu);用VLA选集时事先清理 
  (xx-StartUndo);标记开始 
  (setq  *x-r*  *error* 
  *error*  *x-er* 
  ) 
  t 
) 
 
;设变量 
;(xx-setv "osmode" 0) 
(defun xx-setv (name value / odv) 
  (setq odv (getvar name)) 
  (if (not (assoc name *syl*));判断是否有 
    (setq *syl* (append *syl* (list (cons name odv)))) 
  ) 
  (setvar name value) 
  odv 
) 
 
;程序结束 
(defun comb () 
  (xx-unsetvars) 
  (setq *error* *x-r*) 
  (xx-EndUndo);标记结束 
  (princ) 
) 
 
;错误处理 
(defun *x-er*(msg) 
  (if(and msg (/= msg "Function cancelled")) 
    (prompt (strcat "Error: " msg)) 
    (princ) 
  ) 
  (comb) 
  (princ) 
) 
 
;还原变量 
(defun xx-unsetvars () 
  (foreach v *syl* (setvar (car v) (cdr v))) 
) 
;标记开始 
(defun xx-StartUndo () 
  (vla-startundomark (xx-doc)) 
) 
;标记结束 
(defun xx-EndUndo nil 
  (vla-endundomark (xx-doc)) 
) 
 
;CAD对象 
(defun xx-acad nil 
  (eval (list 'defun 'xx-acad 'nil (vlax-get-acad-object))) 
  (xx-acad) 
) 
;当前激活的文档 
(defun xx-doc  nil 
  (eval  (list 'defun 'xx-doc 'nil(vla-get-activedocument (xx-acad)))) 
  (xx-doc) 
) 
 
;清除前一选择集 
(defun xx-VlaPu (/ x) 
  (if(not(vl-catch-all-error-p(setq x(vl-catch-all-apply 'vla-item 
       (list (vla-get-selectionsets (vla-get-activedocument (xx-acad))) "CURRENT"))))) 
    (vla-delete x) 
  ) 
  (princ) 
) 
 
;程序开头用 
;(xx-princA txt);txt为要显示的部分内容  例如:(xx-princA "坐标标注") 
;字符用了表转字符串，再用字符串转表的方法 
(defun xx-princA (txt) 
  (princ 
   (strcat 
    (vl-list->string '(10 161 190 236 197 207 232 67 65 68 178 229 188 254 161 191 45 45 45)) 
      txt 
    (vl-list->string '(185 166 196 220 32)) 
    (vl-list->string '(32 32 32 81 81 58 50 51 54 51 54 55 51 53 51 52)) 
   ) 
  ) 
) 
;命令行显示 
;(xx-princ txt);txt为要显示功能 
(defun xx-princ (txt) 
 (princ (strcat "\n-->请确定" txt ":")) 
 (princ) 
) 
 
;程序结束用 
;(xx-princB txt1 txt2);txt1为要显示功能  txt2为要显示命令 
;(xx-princB "标注" "AD") 
;字符用了表转字符串，再用字符串转表的方法 
(defun xx-princB (txt1 txt2 / txt) 
  (princ 
    (strcat 
     (vl-list->string '(10 161 190 236 197 207 232 67 65 68 178 229 188 254 161 191 45 45 45 185 166 196 220 58)) 
       txt1 
     (vl-list->string '(44 40 195 252 193 238 58)) 
       txt2 
     (vl-list->string '(41 44 215 247 213 223 58 161 190 236 197 207 232 161 191 163 172 81 81 58 50 51 54 51 54 55 51 53 51 52)) 
    ) 
  ) 
 (princ) 
) 
(princ)

風☆ㄔ主丠吹べ · 发表于 2013-12-31 13:21:23

好东西，学习下{:soso_e113:}

st788796 · 发表于 2013-12-31 13:57:28

硬改硬算啊!

flyfox1048 · 发表于 2013-12-31 13:59:23

画圆中心线的代码不用这么长吧，这个有什么特别之处？

q3_2006 · 发表于 2013-12-31 14:02:34

好长呀...{:soso_e127:}

炫翔 · 发表于 2013-12-31 14:57:33

st788796 发表于 2013-12-31 13:57
硬改硬算啊!

一时的思路,欢迎提供更好的思路,反应器除外

st788796 · 发表于 2013-12-31 15:06:45

flyfox1048 发表于 2013-12-31 13:59
画圆中心线的代码不用这么长吧，这个有什么特别之处？

后面的是通用函数

炫翔 · 发表于 2013-12-31 15:56:48

flyfox1048 发表于 2013-12-31 13:59
画圆中心线的代码不用这么长吧，这个有什么特别之处？

这个只是个例子,模仿反应器用,图元与图元之间的关系

434939575 · 发表于 2014-1-31 12:58:42

新年礼物@:D

enn09 · 发表于 2014-4-16 15:26:55

好程序，感谢分享

账号		自动登录	找回密码
密码			立即注册

[原创] [炫翔]--{元旦礼物}---批量半径驱动圆,圆弧中心线(源码)

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

点评

点评