如何把一段折线(pline)展开成相同延长度的直线(pline)?
补充图片说明.并附CAD图,不知有没有类似的lsp?求大招. (defun makepl(arg);;arg==>(list pts 闭合标志 全局宽度 线宽 图层 颜色 厚度 线型)pts以后可省略(entmakex(append(mapcar'cons'(0 100 100 43 370 8 62 39 6)(append'("LWPOLYLINE""AcDbEntity""AcDbPolyline")(cddr arg)))
(cons(cons 90(length(car arg)))(cons(cons 70(if(cadr arg)(cadr arg)0))(mapcar'(lambda(x)(cons 10 x))(car arg)))))))
(defun c:tt(/ e p l)
(while(and(setq l nil e(car(entsel"选择需要展开的曲线")))
(setq n(VL-CATCH-ALL-APPLY'vlax-curve-getendparam(list e)))
(setq p(getpoint"指定展开线起点:")))
(cond((WCMATCH(cdr(assoc 0(entget e)))"*POLYLINE")
(while(setq p(vlax-curve-getdistatparam e n))
(setq l(cons(polar p 0(vlax-curve-getdistatparam e n))l)n(1- n)))
(makepl(List l)))
(t(makepl(list(list p(polar p 0(-(vlax-curve-getdistatparam e(vlax-curve-getendparam e))(vlax-curve-getdistatparam e(vlax-curve-getstartparam e))))))))))) langjs 发表于 2012-6-14 09:12
对LWPOLYLINE和POLYLINE都有效
大神，这个代码可以给定一个高度，再连接上下每条线段的端点吗 展开线啊.没有人关注吗?顶上 (defun c:aa (/ d ent lst name p0 p1 p2 pt1 pt2 pt3 ss txt x)
(defun dim (pt1 pt2 / d p0 txt)
(setq d (distance pt1 pt2) txt (rtos d) p2 (polar p1 0.0 d)p0 (polar p1 0.0 (* 0.5 d)))
(entmake (list '(0 . "LINE") (cons 62 3) (cons 10 p1) (cons 11 p2)))
(entmake (list '(0 . "TEXT") (cons 62 2) (cons 10 p0) (cons 40 300) (cons 1 txt) '(41 . 0.8) '(72 . 1) ;字高300
(cons 11 p0) '(73 . 0)) )
(setq p1 p2)
)
(setvar "cmdecho" 0)
(vl-load-com)
(setq ss (ssget ":E:S" '((0 . "LWPOLYLINE"))))
(setq p1 (getpoint "指定基点")name (ssname ss 0) ent (entget name) lst nil )
(foreach x ent
(if (= (car x) 10) (setq lst (cons (cdr x) lst)))
)
(setq lst (reverse lst) pt1 nil pt2 nil )
(foreach x lst
(if (null pt1)(setq pt1 x pt3 x )(setq pt2 x))
(if pt2 (progn (dim pt1 pt2) (setq pt1 pt2)))
)
(if (= 1 (cdr (assoc 70 ent))) (dim pt2 pt3))
(princ)
)
谢谢楼上的..只对LWPOLYLINE有效..如果是POLYLINE就要自己先(CONVERTPOLY)转换了..万分感谢!! 可以,有了线变成pline也是很容易的事.楼下已完成,试用过有效,感谢. alex0007 发表于 2012-6-13 22:42 static/image/common/back.gif
谢谢楼上的..只对LWPOLYLINE有效..如果是POLYLINE就要自己先(CONVERTPOLY)转换了..万分感谢!!
对LWPOLYLINE和POLYLINE都有效
(defun c:aa ( / d ent j n name p0 p1 p2 pt1 pt2 pt3 ptslist ss txt vtxlst x)
(defun dim (pt1 pt2 / d p0 txt)
(setq d (distance pt1 pt2) txt (rtos d) p2 (polar p1 0.0 d) p0 (polar p1 0.0 (* 0.5 d)) )
(entmake (list '(0 . "LINE") (cons 62 3) (cons 10 p1) (cons 11 p2)))
(entmake (list '(0 . "TEXT") (cons 62 2) (cons 10 p0) (cons 40 300) (cons 1 txt) '(41 . 0.8) '(72 . 1) ; 字高300
(cons 11 p0) '(73 . 0)) )
(setq p1 p2)
)
(setvar "cmdecho" 0)
(vl-load-com)
(setq ss (ssget ":E:S" '((0 . "LWPOLYLINE,POLYLINE"))))
(setq p1 (getpoint "指定基点")name (ssname ss 0)ent (entget name)ptslist nilj 0 )
(if (= "LWPOLYLINE" (cdr (assoc 0 ent)))(setq n 2)(setq n 3))
(setq vtxlst (vlax-safearray->list (vlax-variant-value (vlax-get-property (vlax-ename->vla-object name) 'coordinates))))
(repeat (/ (length vtxlst) n)
(setq ptslist(append ptslist (list (list (nth j vtxlst) (nth (1+ j) vtxlst) (if (= n 3)(nth (+ 2 j) vtxlst)0.0 )))))
(setq j (+ j n))
)
(setq pt1 nil pt2 nil )
(foreach x ptslist
(if (null pt1) (setq pt1 xpt3 x ) (setq pt2 x))
(if pt2 (progn (dim pt1 pt2) (setq pt1 pt2)))
)
(if (= 1 (cdr (assoc 70 ent))) (dim pt2 pt3))
(princ)
)
这个非常好。。希望增加弧线也能展开。让程序最完美~
希望展开后断点插入一直线~~ flytoday 发表于 2012-6-14 10:06 static/image/common/back.gif
希望展开后断点插入一直线~~
6楼的程序稍稍加了几句 楼上的文件，不能下载！！
页:
[1]
2