[原创]圆弧转多段线

gao6690

;圆弧转多段线
;h为弓高（即弦中心至相对应弧之中心的距离）
;它用来描述以弦代弧的光滑程度，一般化取0.005mm(图上距离)即可
(defun arc->pline(ent h / xtblm xtblz db r po a0 h n)
(setq xtblm '("cmdecho" "osmode")
xtblz (mapcar 'getvar xtblm)
db (entget ent) r (cdr (assoc 40 db))
po (cdr (assoc 10 db))
a0 (cdr (assoc 50 db))
db (- (cdr (assoc 51 db)) a0)
db (cond ((< db 0) (+ (* 2.0 pi) db))
(t db)
)
n (fix (/ db (atan (/ (sqrt (- (* 2.0 r h) (* h h))) (- r h)))))
db (/ db n)
)
(mapcar 'setvar xtblm '(0 0))
(command "_pline" (polar po a0 r))
(repeat n (command (polar po (setq a0 (+ a0 db)) r)))
(command "" "_matchprop" ent (entlast) "" "_erase" ent "" "redraw")
(mapcar 'setvar xtblm xtblz)(princ)
)

;测试程序
(defun cc()
(setq t0 (getvar "cdate"))
(arc->pline (car (entsel "\n请选取要转化多段线的圆弧:")) 0.005)
(princ (strcat "\n耗时：" (rtos (* 1000000 (- (getvar "cdate") t0) 2 3)) "秒"))
(princ)
)

小毛草

可以试下这个程序，可以多选！

2. ;;;-----------------------------------------------------
   
3. ;;; 功能：批量将圆弧转换为多段线（支持逆向圆弧）
   
4. ;;;-----------------------------------------------------
   
5. 
   
6. (defun c:ARC2PL ( / *error* acadObj doc ss i ename oldVars h)
   
7.   ;; 错误处理函数
   
8.   (defun *error* (msg)
   
9.     (if doc (vla-endundomark doc))
   
10.     (if oldVars (mapcar 'setvar '("CMDECHO" "OSMODE") oldVars))
    
11.     (princ (strcat "\n错误: " msg))
    
12.   )
    
13.   
    
14.   (setq acadObj (vlax-get-acad-object)
    
15.         doc (vla-get-activedocument acadObj)
    
16.         oldVars (list (getvar "CMDECHO") (getvar "OSMODE"))) ; 修正变量存储方式
    
17.   
    
18.   (setvar "CMDECHO" 0)
    
19.   (setvar "OSMODE" 0)
    
20.   
    
21.   ;; 用户输入弓高（默认0.005）
    
22.   (initget 6)
    
23.   (setq h (getreal "\n输入弓高精度<0.005>: "))
    
24.   (if (not h) (setq h 0.005))
    
25.   
    
26.   (if (setq ss (ssget '((0 . "ARC"))))
    
27.     (progn
    
28.       (vla-startundomark doc)
    
29.       (setq i 0)
    
30.       (repeat (sslength ss)
    
31.         (setq ename (ssname ss i))
    
32.         (arc->polyline ename h)
    
33.         (setq i (1+ i))
    
34.       )
    
35.       (vla-endundomark doc)
    
36.       (princ (strcat "\n成功转换 " (itoa i) " 个圆弧"))
    
37.     )
    
38.     (princ "\n未选择任何圆弧")
    
39.   )
    
40.   (mapcar 'setvar '("CMDECHO" "OSMODE") oldVars)
    
41.   (princ)
    
42. )
    
43. 
    
44. ;;;-----------------------------------------------------
    
45. ;;; 核心转换函数
    
46. ;;; 参数：ename - 圆弧图元名
    
47. ;;;       h     - 最大允许弓高
    
48. ;;;-----------------------------------------------------
    
49. (defun arc->polyline (ename h / elst r pts)
    
50.   ;; 获取圆弧关键参数
    
51.   (setq elst (entget ename)
    
52.         r (cdr (assoc 40 elst)))
    
53.   
    
54.   ;; 计算顶点列表
    
55.   (setq pts (arc-divide ename h r)) ; 增加半径参数传递
    
56.   
    
57.   ;; 构建多段线数据
    
58.   (entmakex
    
59.     (append
    
60.       (list
    
61.         '(0 . "LWPOLYLINE")
    
62.         '(100 . "AcDbEntity")
    
63.         (assoc 8 elst)   ; 保留图层
    
64.         (if (assoc 62 elst) (assoc 62 elst) '(62 . 256)) ; 处理未设置颜色
    
65.         (if (assoc 6 elst) (assoc 6 elst) '(6 . "BYLAYER")) ; 处理未设置线型
    
66.         '(100 . "AcDbPolyline")
    
67.         (cons 90 (length pts))
    
68.         '(70 . 0)
    
69.         (if (assoc 38 elst) (assoc 38 elst) '(38 . 0.0)) ; 处理标高
    
70.         (if (assoc 210 elst) (assoc 210 elst) '(210 (0.0 0.0 1.0))) ; 默认法向量
    
71.       )
    
72.       (mapcar '(lambda (p) (cons 10 p)) pts) ; 简化坐标处理
    
73.     )
    
74.   )
    
75.   (entdel ename) ; 删除原始圆弧
    
76.   (princ)
    
77. )
    
78. 
    
79. ;;;-----------------------------------------------------
    
80. ;;; 圆弧分割算法（修正版）
    
81. ;;; 返回顶点坐标列表（包含起点和终点）
    
82. ;;;-----------------------------------------------------
    
83. (defun arc-divide (ename h r / startParam endParam totalAngle segAngle n pts param)
    
84.   (setq startParam (vlax-curve-getStartParam ename)
    
85.         endParam (vlax-curve-getEndParam ename)
    
86.         totalAngle (abs (- endParam startParam)))
    
87.   
    
88.   ;; 计算分段数（基于弓高公式）
    
89.   (if (> r h)
    
90.     (progn
    
91.       (setq segAngle (* 2 (acos (/ (- r h) r)))
    
92.       (setq n (max (fix (/ totalAngle segAngle)) 1))
    
93.       (setq segAngle (/ totalAngle n))
    
94.     )
    
95.     (setq n 1) ; 处理半径过小的情况
    
96.   )
    
97.   
    
98.   ;; 生成顶点参数表
    
99.   (setq pts (list (vlax-curve-getStartPoint ename)))
    
100.   (repeat (1- n)
     
101.     (setq param (+ startParam (* segAngle (length pts))))
     
102.     (setq pts (cons (vlax-curve-getPointAtParam ename param) pts))
     
103.   )
     
104.   (reverse (cons (vlax-curve-getEndPoint ename) pts))
     
105. )
     
106. 
     
107. ;;;-----------------------------------------------------
     
108. ;;; 辅助函数：反余弦计算（修正括号匹配）
     
109. ;;;-----------------------------------------------------
     
110. (defun acos (x)
     
111.   (cond
     
112.     ((>= x 1.0) 0.0)
     
113.     ((<= x -1.0) pi)
     
114.     (t (atan (sqrt (- 1.0 (* x x))) x)
     
115.   )
     
116. )
     
117. 
     
118. (princ "\n圆弧转多段线命令已加载，请输入 ARC2PL 执行")
     
119. (princ)

;;;-----------------------------------------------------<br /> ;;; 功能：批量将圆弧转换为多段线（支持逆向圆弧）<br /> ;;;-----------------------------------------------------<br /> <br /> (defun c:ARC2PL ( / *error* acadObj doc ss i ename oldVars h)<br />   ;; 错误处理函数<br />   (defun *error* (msg)<br />     (if doc (vla-endundomark doc))<br />     (if oldVars (mapcar 'setvar '("CMDECHO" "OSMODE") oldVars))<br />     (princ (strcat "\n错误: " msg))<br />   )<br />   <br />   (setq acadObj (vlax-get-acad-object)<br />         doc (vla-get-activedocument acadObj)<br />         oldVars (list (getvar "CMDECHO") (getvar "OSMODE"))) ; 修正变量存储方式<br />   <br />   (setvar "CMDECHO" 0)<br />   (setvar "OSMODE" 0)<br />   <br />   ;; 用户输入弓高（默认0.005）<br />   (initget 6)<br />   (setq h (getreal "\n输入弓高精度<0.005>: "))<br />   (if (not h) (setq h 0.005))<br />   <br />   (if (setq ss (ssget '((0 . "ARC"))))<br />     (progn<br />       (vla-startundomark doc)<br />       (setq i 0)<br />       (repeat (sslength ss)<br />         (setq ename (ssname ss i))<br />         (arc->polyline ename h)<br />         (setq i (1+ i))<br />       )<br />       (vla-endundomark doc)<br />       (princ (strcat "\n成功转换 " (itoa i) " 个圆弧"))<br />     )<br />     (princ "\n未选择任何圆弧")<br />   )<br />   (mapcar 'setvar '("CMDECHO" "OSMODE") oldVars)<br />   (princ)<br /> )<br /> <br /> ;;;-----------------------------------------------------<br /> ;;; 核心转换函数<br /> ;;; 参数：ename - 圆弧图元名<br /> ;;;       h     - 最大允许弓高<br /> ;;;-----------------------------------------------------<br /> (defun arc->polyline (ename h / elst r pts)<br />   ;; 获取圆弧关键参数<br />   (setq elst (entget ename)<br />         r (cdr (assoc 40 elst)))<br />   <br />   ;; 计算顶点列表<br />   (setq pts (arc-divide ename h r)) ; 增加半径参数传递<br />   <br />   ;; 构建多段线数据<br />   (entmakex<br />     (append<br />       (list<br />         '(0 . "LWPOLYLINE")<br />         '(100 . "AcDbEntity")<br />         (assoc 8 elst)   ; 保留图层<br />         (if (assoc 62 elst) (assoc 62 elst) '(62 . 256)) ; 处理未设置颜色<br />         (if (assoc 6 elst) (assoc 6 elst) '(6 . "BYLAYER")) ; 处理未设置线型<br />         '(100 . "AcDbPolyline")<br />         (cons 90 (length pts))<br />         '(70 . 0)<br />         (if (assoc 38 elst) (assoc 38 elst) '(38 . 0.0)) ; 处理标高<br />         (if (assoc 210 elst) (assoc 210 elst) '(210 (0.0 0.0 1.0))) ; 默认法向量<br />       )<br />       (mapcar '(lambda (p) (cons 10 p)) pts) ; 简化坐标处理<br />     )<br />   )<br />   (entdel ename) ; 删除原始圆弧<br />   (princ)<br /> )<br /> <br /> ;;;-----------------------------------------------------<br /> ;;; 圆弧分割算法（修正版）<br /> ;;; 返回顶点坐标列表（包含起点和终点）<br /> ;;;-----------------------------------------------------<br /> (defun arc-divide (ename h r / startParam endParam totalAngle segAngle n pts param)<br />   (setq startParam (vlax-curve-getStartParam ename)<br />         endParam (vlax-curve-getEndParam ename)<br />         totalAngle (abs (- endParam startParam)))<br />   <br />   ;; 计算分段数（基于弓高公式）<br />   (if (> r h)<br />     (progn<br />       (setq segAngle (* 2 (acos (/ (- r h) r)))<br />       (setq n (max (fix (/ totalAngle segAngle)) 1))<br />       (setq segAngle (/ totalAngle n))<br />     )<br />     (setq n 1) ; 处理半径过小的情况<br />   )<br />   <br />   ;; 生成顶点参数表<br />   (setq pts (list (vlax-curve-getStartPoint ename)))<br />   (repeat (1- n)<br />     (setq param (+ startParam (* segAngle (length pts))))<br />     (setq pts (cons (vlax-curve-getPointAtParam ename param) pts))<br />   )<br />   (reverse (cons (vlax-curve-getEndPoint ename) pts))<br /> )<br /> <br /> ;;;-----------------------------------------------------<br /> ;;; 辅助函数：反余弦计算（修正括号匹配）<br /> ;;;-----------------------------------------------------<br /> (defun acos (x)<br />   (cond<br />     ((>= x 1.0) 0.0)<br />     ((<= x -1.0) pi)<br />     (t (atan (sqrt (- 1.0 (* x x))) x)<br />   )<br /> )<br /> <br /> (princ "\n圆弧转多段线命令已加载，请输入 ARC2PL 执行")<br /> (princ)

yjtdkj

去掉了command命令，重新写了一遍，速度快多了

1. ;圆弧转多段线
   
2. ;h为弓高（即弦中心至相对应弧之中心的距离）
   
3. ;它用来描述以弦代弧的光滑程度，一般化取0.005mm(图上距离)即可
   
4. (defun arc->pline (en h / xtblm xtblz ALEN ENT LEN LST N PT PTLST R SUM)
   
5.   (setq #t0# (getvar "cdate"))
   
6.   (setq        xtblm '("cmdecho" "osmode")
   
7.         xtblz (mapcar 'getvar xtblm)
   
8.         r     (yj-dxf 40 en)
   
9.         len   (vlax-curve-getDistAtPoint en (vlax-curve-getEndPoint en))
   
10.         alen  (* (atan (/ (sqrt (- (* 2.0 r h) (* h h))) (- r h))) r)
    
11.         n     (fix (/ len alen))
    
12.         alen  (/ len n)
    
13.         sum   alen
    
14.         ptlst '()
    
15.   )
    
16.   (repeat n
    
17.     (setq pt (vlax-curve-getpointatdist en sum))
    
18.     (setq ptlst (append ptlst (list (cons 10 pt)(cons 40 0)(cons 41 0)(cons 42 0)) ))
    
19.     (setq sum (+ sum alen))
    
20.     )
    
21.   (setq ent (entget en))
    
22.   (setq lst '((0 . "LWPOLYLINE")))
    
23.      (foreach x '(100 67 410 8 62 6 370)
    
24.        (if (assoc x
    
25.                   ent
    
26.            ) ;_  assoc
    
27.          (setq lst (cons (assoc x ent) lst))
    
28.        ) ;_  if
    
29.      ) ;_  foreach
    
30.      (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
    
31.      (entmakex
    
32.        (append
    
33.          (reverse lst)
    
34.          (list
    
35.            '(100 . "AcDbPolyline")
    
36.            (cons 90 (1+ n))
    
37.            '(70 . 0)
    
38.            (cons 38 (cadddr (assoc 10 ent)))
    
39.            (cons
    
40.              10
    
41.              (vlax-curve-getStartPoint en
    
42.              ) ;_  reverse
    
43.            ) ;_  cons
    
44.            '(40 . 0)
    
45.            '(41 . 0)
    
46.            '(42 . 0)
    
47.          )
    
48.          ptlst
    
49.          (list
    
50.            (assoc 210 ent)
    
51.          ) ;_  list
    
52.        ) ;_  append
    
53.      ) ;_  entmakex
    
54.      ;(Vlax-Put-Property (Vlax-Ename->Vla-Object (entlast)) 'Color 1)
    
55.      (entdel en)
    
56.      (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
    
57.   (mapcar 'setvar xtblm xtblz)
    
58.   (princ)
    
59. )
    
60. ;;;按指组码找出全图元的组码值
    
61.     (defun yj-dxf (key ename) (cdr (assoc key (entget ename))))   
    
62. ;测试程序
    
63. (defun cc ()
    
64.   (arc->pline (car (entsel "\n请选取要转化多段线的圆弧:"))
    
65.               0.05
    
66.   )
    
67.   (princ
    
68.     (strcat "\n耗时："
    
69.             (rtos (* 1000000 (- (getvar "cdate") #t0#) 2 3))
    
70.             "秒"
    
71.     )
    
72.   )
    
73.   (princ)
    
74. )
    

;圆弧转多段线<br /> ;h为弓高（即弦中心至相对应弧之中心的距离）<br /> ;它用来描述以弦代弧的光滑程度，一般化取0.005mm(图上距离)即可<br /> (defun arc->pline (en h / xtblm xtblz ALEN ENT LEN LST N PT PTLST R SUM)<br />   (setq #t0# (getvar "cdate"))<br />   (setq        xtblm '("cmdecho" "osmode")<br />         xtblz (mapcar 'getvar xtblm)<br />         r     (yj-dxf 40 en)<br />         len   (vlax-curve-getDistAtPoint en (vlax-curve-getEndPoint en))<br />         alen  (* (atan (/ (sqrt (- (* 2.0 r h) (* h h))) (- r h))) r)<br />         n     (fix (/ len alen))<br />         alen  (/ len n)<br />         sum   alen<br />         ptlst '()<br />   )<br />   (repeat n <br />     (setq pt (vlax-curve-getpointatdist en sum))<br />     (setq ptlst (append ptlst (list (cons 10 pt)(cons 40 0)(cons 41 0)(cons 42 0)) ))<br />     (setq sum (+ sum alen))<br />     )<br />   (setq ent (entget en))<br />   (setq lst '((0 . "LWPOLYLINE"))) <br />      (foreach x '(100 67 410 8 62 6 370) <br />        (if (assoc x <br />                   ent <br />            ) ;_  assoc <br />          (setq lst (cons (assoc x ent) lst)) <br />        ) ;_  if <br />      ) ;_  foreach <br />      (vla-startundomark (vla-get-activedocument (vlax-get-acad-object))) <br />      (entmakex<br />        (append<br />          (reverse lst)<br />          (list<br />            '(100 . "AcDbPolyline")<br />            (cons 90 (1+ n))<br />            '(70 . 0)<br />            (cons 38 (cadddr (assoc 10 ent)))<br />            (cons<br />              10<br />              (vlax-curve-getStartPoint en<br />              ) ;_  reverse <br />            ) ;_  cons <br />            '(40 . 0)<br />            '(41 . 0)<br />            '(42 . 0)<br />          )<br />          ptlst<br />          (list<br />            (assoc 210 ent)<br />          ) ;_  list <br />        ) ;_  append <br />      ) ;_  entmakex<br />      ;(Vlax-Put-Property (Vlax-Ename->Vla-Object (entlast)) 'Color 1)<br />      (entdel en) <br />      (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))) <br />   (mapcar 'setvar xtblm xtblz)<br />   (princ)<br /> )<br /> ;;;按指组码找出全图元的组码值<br />     (defun yj-dxf (key ename) (cdr (assoc key (entget ename))))   <br /> ;测试程序<br /> (defun cc ()<br />   (arc->pline (car (entsel "\n请选取要转化多段线的圆弧:"))<br />               0.05<br />   )<br />   (princ<br />     (strcat "\n耗时："<br />             (rtos (* 1000000 (- (getvar "cdate") #t0#) 2 3))<br />             "秒"<br />     )<br />   )<br />   (princ)<br /> )<br />

xyp1964

1. (defun c:tt ()
   
2.   "圆弧转多段线"
   
3.   (princ "\n选择圆弧实体<退出>: ")
   
4.   (if (setq ss (ssget '((0 . "arc"))))
   
5.     (progn
   
6.       (setvar "PEDITACCEPT" 1)
   
7.       (command "pedit" "m" ss "" "")
   
8.     )
   
9.   )
   
10.   (princ)
    
11. )

(defun c:tt ()<br />   "圆弧转多段线"<br />   (princ "\n选择圆弧实体<退出>: ")<br />   (if (setq ss (ssget '((0 . "arc"))))<br />     (progn<br />       (setvar "PEDITACCEPT" 1)<br />       (command "pedit" "m" ss "" "")<br />     )<br />   )<br />   (princ)<br /> )

nonsmall

这个程序楼主改进成为

圆弧多线段转pline会有用些吧?

ninja37

yjtdkj 发表于 2021-6-25 10:36
去掉了command命令，重新写了一遍，速度快多了

大师，这个程序 在cad里面是哪一个命令啊。

yjtdkj

ninja37 发表于 2021-6-25 21:20
大师，这个程序 在cad里面是哪一个命令啊。

把(defun cc ()改为(defun c:cc ()
然后在CAD里就可以用CC命令了，也可以改成你想要的

ninja37

yjtdkj 发表于 2021-6-26 06:33
把(defun cc ()改为(defun c:cc ()
然后在CAD里就可以用CC命令了，也可以改成你想要的

谢谢 已经在用了  很好用

caocaosasd

yjtdkj 发表于 2021-6-26 06:33
把(defun cc ()改为(defun c:cc ()
然后在CAD里就可以用CC命令了，也可以改成你想要的

大神，有没有办法批量把选中的弧线分别直接替换成直线呢？就是弧变成弦，弦的形式是直线

yjtdkj

caocaosasd 发表于 2021-6-27 21:33
大神，有没有办法批量把选中的弧线分别直接替换成直线呢？就是弧变成弦，弦的形式是直线

1. (defun c:tt ()
   
2.   (setq en (car (entsel)))
   
3.   (setq pt1 (vlax-curve-getStartPoint en))
   
4.   (setq pt2 (vlax-curve-getendPoint en))
   
5.   (entmake
   
6.     (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2))
   
7.   )
   
8.   (entdel en)
   
9.   (entlast)
   
10. )

(defun c:tt ()<br />   (setq en (car (entsel)))<br />   (setq pt1 (vlax-curve-getStartPoint en))<br />   (setq pt2 (vlax-curve-getendPoint en))<br />   (entmake<br />     (list '(0 . "LINE") (cons 10 pt1) (cons 11 pt2))<br />   )<br />   (entdel en)<br />   (entlast)<br /> )

大尾巴狼

很不错，要是能多选就更好了

lizhiqiang9801

程序运行流畅  能修改成框选就完美了