我写的加中心线的程序，可以加矩形、圆、平行线的

燃烧

可以加矩形中心线，可以说是万能的了！
(defun C:CR (/     en    en_data         lx     pt0
      nx     cenpt  r   pt3x  pt3y pt4x   pt4y   pt5
      pt5x   pt5y   pt6   pt6x  pt6y l      l1     en3
      en1    en1_data   en2  en2_data
     )
  (terpri)
  (prin1 "This program is to add centerline! by 向赞扬!")
  (setq v1 (getvar "osmode"))
  (setq v2 (getvar "cmdecho"))
  (setq v3 (getvar "blipmode"))
  (setvar "cmdecho" 0)
  (setvar "blipmode" 0)
  (SETVAR "OSMODE" 0)
  (graphscr)
  (setq en (entsel "\nselection a object!"))
  (setq en_data (entget (car en)))
  (setq lx_list (assoc 0 en_data))
  (setq lx (cdr lx_list))
  (cond ((= "CIRCLE" lx)
  (progn
    (setq v4 (getvar "CLAYER"))
    (setq pt0 (cadr en))
    (setq nx (cdr (assoc 0 en_data)))
    (setq cenpt (osnap pt0 "center"))
    (setq r (cdr (assoc 40 en_data)))
    (setq pt1 (polar cenpt pi (+ (* r 0.2) r)))
    (setq pt2 (polar cenpt 0 (+ (* r 0.2) r)))
    (setq pt3 (polar cenpt (* 0.5 pi) (+ (* r 0.2) r)))
    (setq pt4 (polar cenpt (* 1.5 pi) (+ (* r 0.2) r)))
    (command "osnap" "none")
    (if (not (tblsearch "LAYER" "Cen"))
      (command "layer" "m" "Cen" "c" 2 "" "l" "center2" "" "lw"
        0.18 "" "")
    )
    (command "layer" "s" "cen" "")
    (command "line" pt1 pt2 "")
    (command "line" pt3 pt4 "")
    (setvar "CLAYER" v4)
  )
)
((= "ARC" lx)
  (progn
    (setq v4 (getvar "CLAYER"))
    (setq pt0 (cadr en))
    (setq nx (cdr (assoc 0 en_data)))
    (setq cenpt (osnap pt0 "center"))
    (setq r (cdr (assoc 40 en_data)))
    (setq pt1 (polar cenpt pi (+ (* r 0.2) r)))
    (setq pt2 (polar cenpt 0 (+ (* r 0.2) r)))
    (setq pt3 (polar cenpt (* 0.5 pi) (+ (* r 0.2) r)))
    (setq pt4 (polar cenpt (* 1.5 pi) (+ (* r 0.2) r)))
    (command "osnap" "none")
    (if (not (tblsearch "LAYER" "Cen"))
      (command "layer" "m" "Cen" "c" 2 "" "l" "center2" "" "lw"
        0.18 "" "")
    )
    (command "layer" "s" "cen" "")
    (command "line" pt1 pt2 "")
    (command "line" pt3 pt4 "")
    (setvar "CLAYER" v4)
  )
)
((= "LINE" lx)
  (progn
    (setq v4 (getvar "CLAYER"))
    (setq pt1 (osnap (cadr en) "nearest"))
    (setq en1   (entsel "\n selection another line")
   en1_data (entget (car en1))
    )
    (setq pt2 (osnap (cadr en1) "nearest"))
    (command "line" pt1 (osnap pt2 "perpendicular") "")
    (setq en2 (entlast))
    (setq en2_data (entget en2))
    (setq pt3x (cadr (assoc 10 en2_data)))
    (setq pt3y (caddr (assoc 10 en2_data)))
    (setq pt3 (list pt3x pt3y))
    (setq pt4x (cadr (assoc 11 en2_data)))
    (setq pt4y (caddr (assoc 11 en2_data)))
    (setq pt4 (list pt4x pt4y))
    (setq l (distance pt3 pt4))
    (SETQ l1 (/ l 2))
    (command "offset" l1 en pt2 "")
    (setq en3 (entlast))
    (if (not (tblsearch "LAYER" "Cen"))
      (command "layer" "m" "Cen" "c" 2 "" "l" "center2" "" "lw"
        0.18 "" "")
    )
    (command "change" en3 "" "p" "la" "Cen" "c" "byl" "lt" "byl"
      "")
    (setq pt5x (cadr (assoc 10 (entget en3)))
   pt5y (caddr (assoc 10 (entget en3)))
   pt5  (list pt5x pt5y)
   pt6x (cadr (assoc 11 (entget en3)))
   pt6y (caddr (assoc 11 (entget en3)))
   pt6  (list pt6x pt6y)
    )
    (command "osnap" "none")
    (command "lengthen" "de" 3 pt5 "")
    (command "lengthen" "de" 3 pt6 "")
    (command "ERASE" en2 "")
    (setvar "CLAYER" v4)
  )
)
((= "LWPOLYLINE" lx)
  (progn
    (SETVAR "OSMODE" 0)
    (command "ucs" "w" )
    (setq v4 (getvar "CLAYER"))
    (setq pt1(cdr(assoc 10 en_data))
    )
    (setq listlength(length en_data))
   (setq pt4(cdr(nth (-  listlength 5) en_data)))
    (setq pt3(cdr(nth (-  listlength 9) en_data)))
    (setq pt2(cdr(nth (-  listlength 13) en_data)))
    (setq al(angle pt1 pt2))
    (setq l(distance pt1 pt2))
    (setq h(distance pt1 pt4))
           (command "line" pt1 pt3 "")
    (setq en2 (entlast))
    (command "_divide" en2 2)
    (setq en3(entlast))
    (setq en3_data (entget en3))
    (setq cenpt(cdr(assoc 10 en3_data)))
    (setq pt5(polar cenpt (+ pi al) (/ l 2)))
    (setq pt6(polar cenpt al (/ l 2)))
    (setq pt7(polar cenpt (+ al (* pi 1.5)) (/ h 2)))
    (setq pt8(polar cenpt (+ al (/ pi 2)) (/ h 2)))
    (command "erase" en2 en3 "")
    (if (not (tblsearch "LAYER" "Cen"))
    (command "layer" "m" "Cen" "c" 2 "" "l" "center2" "" "lw" 0.18 "" "")
  )
(command "layer" "s" "cen" "")    (command "line" pt5 pt6 "")
    (setq en4(entlast))
    (command "line" pt7 pt8 "")
    (setq en5(entlast))
    (setq dee(* 0.1 l))
    (command "lengthen" "de" dee pt5 pt6 pt7 pt8 "")
    ;(print "Selective is spline can't add centerline!")
    (setvar "CLAYER" v4)
  )
)
  )
  (setvar "osmode" v1)
  (setvar "cmdecho" v2)
  (setvar "blipmode" v3)
  (princ)
)

长风（尚品）

xiaoyingzi 发表于 2012-4-27 22:59
修改一下，支持框选，支持圆、圆弧、椭圆、矩形，去掉了平行线

为什么去掉了平行线。可否加上。是否支持 样条线？

h008

669423907 发表于 2012-3-7 15:57
h008 大师整个看看..........

我试试，我是菜鸟，写的代码不够漂亮！

(defun 2d_mid (pt1 pt2);求两点中点 这就是函数应该是来自是明经的
  (mapcar
    '(lambda (x y)
       (/ (+ x y) 2.0)
     )
    pt1
    pt2
  )
)
;;;;;;;;;;;;;;;;;;;;

(defun c:zxx( / ccbs entname list1 list2 bkd bgd cen_po cen_s cen_x cen_z cen_y);中心线
  ;(szkt)设置开头
(command "_layer" "m" "中心线" "C" 6 "" "L" "ACAD_ISO10W100" "" "")
(setq ccbs 1.5);自设个超出倍数 必须大于1
(while (setq entname (car(entsel)))
(vl-load-com)
(vla-GetBoundingBox (vlax-ename->vla-object entname) 'list1 'list2)
(setq list1 (vlax-safearray->list list1))
(setq list2 (vlax-safearray->list list2))
  
(setq  
  bkd (* (- (car list2) (car list1)) ccbs 0.5);半宽度
  bgd (* (- (cadr list2) (cadr list1)) ccbs 0.5);半高度
  cen_po (2d_mid list2 list1)
  cen_s (list (car cen_po) (+ (cadr cen_po) bgd))
  cen_x (list (car cen_po) (- (cadr cen_po) bgd))
  cen_z (list (- (car cen_po) bkd) (cadr cen_po))
  cen_y (list (+ (car cen_po) bkd) (cadr cen_po))  
  )

;(command "rectang" list1 list2)
(command "line" cen_s cen_x "")
(command "line" cen_z cen_y "")  
  
  );while
;(szjs)设置结束
  );;中心线

zhangrunze

h008 发表于 2012-3-8 09:32
我试试，我是菜鸟，写的代码不够漂亮！

(defun 2d_mid (pt1 pt2);求两点中点 这就是函数应该是来自是 ...

感谢~学习了~
不能画平行线的中心线~

精诚网：CREO1.0

楼主有没有测试啊，BUG！！！

yjr111

支持一个！要是能框选就好了，同时command还是能不用最好不用。。。

精诚网：CREO1.0

回来支持，请楼主修改，完善，期待中。。。。。。

669423907

这个必须顶！表示强烈支持！
手机上网中，以后再试！

cabinsummer

精诚网：CREO1.0 发表于 2011-11-13 12:00
回来支持，请楼主修改，完善，期待中。。。。。。

肯定楼主的程序是对的，希望回帖的人好好检查一下你的使用环境

shang_123

要是生成的不是虚线就好了  往楼主修改！

xieyanghui

使用了一下当中还是有些问题！！期待完善

461045462

谢谢楼主的分享
收藏，学习学习

lichunyu

很好啊