[求助]画中心线问题！
<p>从网上下载了一个画中心线的LISP程序</p><p>帮忙分析一下为什么画椭圆中心线的方向是反的。用在AUTOCAD R14英文版下。源程序如下：</p><p><br/>;; 本程序为绘制中心线程序<br/>;; 执行命令：cline<br/>;;<br/>;;确定中心线延伸长度<br/>;(defun adddist (/ defdist)<br/> ; (if dist<br/> ; (progn<br/> ; (princ "\n请输入延伸长度<")<br/> ; (setq defdist (princ dist))<br/> ; (setq dist (getdist ">:"))<br/> ;)<br/> ;(progn<br/> ;(setq defdist 5)</p><p> ; (setq dist (getdist "\n请输入延伸长度<5>:"))<br/> ; )<br/> ; )<br/> ; (if (= dist nil)<br/> ; (setq dist defdist)<br/> ; )<br/> ; dist<br/>;)</p><p>;;确定中心线延伸长度<br/>(defun adddist (/ dist scale)<br/>(setq SCALE (getvar "DIMSCALE"))<br/> (setq DIST (* 3.5 SCALE))<br/>)</p><p>;画圆中心线<br/>(defun circle_cl (en1 / ss i j ent ents ptc r pts adist)<br/> (setq ss (ssget '((0 . "Circle"))))<br/> (setq i 0)<br/> (setq adist(adddist))<br/> (repeat (sslength ss)<br/> (setq ent (ssname ss i))<br/> (setq ents (entget ent))<br/> (setq ptc (cdr (assoc 10 ents))<br/> r (cdr (assoc 40 ents))<br/> j 0<br/> pts'())<br/> (repeat 4<br/> (setq pts (append pts (list (polar ptc (* j (/ pi 2)) (+ r adist)))))<br/> (setq j (1+ j))<br/> )<br/> (command "_.line" (nth 0 pts) (nth 2 pts) ""<br/> "_.line" (nth 1 pts) (nth 3 pts) "")<br/> (setq i (1+ i))<br/> )<br/> (princ)<br/> <br/>)</p><p><br/>;画弧中心线<br/>(defun arc_cl (en1 / ed1 pto rad ang1 ang2 pto1 pt1 pt2 pto2 objline dd adist)<br/> (setq ed1 (entget en1))<br/> (setq pto (cdr (assoc 10 ed1))<br/> rad (cdr (assoc 40 ed1))<br/> ang1 (cdr (assoc 50 ed1))<br/> ang2 (cdr (assoc 51 ed1))<br/> )<br/> (if (> ang1 ang2)<br/> (setq ang2(+ ang2 (* PI 2)))<br/> )<br/> (setq ang (/ (+ ang1 ang2)2))<br/> (setq pto1 (polar pto ang rad))<br/> (setq pt1 (polar pto ang1 rad))<br/> (setq pt2 (polar pto ang2 rad))<br/> (setq pto2 (inters pto pto1 pt1 pt2 nil))<br/> (command "_line" pto1 pto2 "")<br/> (setq objline (entlast)<br/> dd (distance pto1 pto2)<br/> )<br/> (setq adist (adddist))<br/> (command "_lengthen"<br/> "t"<br/> (+ dd adist)<br/> (cons objline (list pto1))<br/> ""<br/> )<br/> (command "_lengthen"<br/> "t"<br/> (+ dd (* adist 2))<br/> (cons objline (list pto2))<br/> ""<br/> )</p><p><br/>)</p><p><br/>;画直线中心线<br/>(defun line_cl (en1 / en2 )<br/> (setq en2 (car (entsel "\n请选择另外的直线<只绘制单直线中心线>:")))<br/> (if en2<br/> (progn<br/> (while (/= "LINE" (cdr (assoc 0 (entget en2))))<br/> (setq en2 (car (entsel "\n请重新选择另外的直线:")))<br/> )<br/> (dline_cl en1 en2)<br/> )<br/> (sline_cl en1)<br/> )<br/>)</p><p><br/>(defun dline_cl (en1 en2 / ed1 ed2 pta1 pta2 ptb1<br/> ptb2 pto ptoo pto1 pto2 anga<br/> angb ango objline dd adist)<br/> (setq ed1 (entget en1)<br/> ed2 (entget en2)<br/> )<br/> (setq pta1 (cdr (assoc 10 ed1))<br/> pta2 (cdr (assoc 11 ed1))<br/> ptb1 (cdr (assoc 10 ed2))<br/> ptb2 (cdr (assoc 11 ed2))<br/> )</p><p> (if (setq pto (inters pta1 pta2 ptb1 ptb2 nil)) ;if 2<br/> (if (inters pta1 pta2 ptb1 ptb2) ;if 3<br/> (princ "\n两线相交，退出")<br/> (progn<br/> (setq anga (angle pto pta1)<br/> angb (angle pto ptb1)<br/> ango (/ (+ anga angb) 2)<br/> ptoo (polar pto ango 1)<br/> ) ;setq<br/> (if (inters pta1 ptb1 pta2 ptb2) ;if 4<br/> (setq pto1 (inters pta1 ptb2 pto ptoo nil)<br/> pto2 (inters pta2 ptb1 pto ptoo nil)<br/> )<br/> (setq pto1 (inters pta1 ptb1 pto ptoo nil)<br/> pto2 (inters pta2 ptb2 pto ptoo nil)<br/> )<br/> ) ;if 4<br/> (command "_line" pto1 pto2 "")<br/> (setq objline (entlast)<br/> dd (distance pto1 pto2)<br/> )<br/> (setq adist (adddist))<br/> (command "_lengthen"<br/> "t"<br/> (+ dd adist)<br/> (cons objline (list pto1))<br/> ""<br/> )<br/> (command "_lengthen"<br/> "t"<br/> (+ dd (* adist 2))<br/> (cons objline (list pto2))<br/> ""<br/> )</p><p><br/> ) ;progn<br/> ) ;if 3<br/> (progn<br/> (arxload "geomcal.arx" nil)<br/> (if (inters pta1 ptb1 pta2 ptb2) ;if 4<br/> (progn<br/> (setq pto1 (c:cal "(pta1 + ptb2) / 2")<br/> pto2 (c:cal "(pta2 + ptb1) / 2")<br/> )<br/> (command "_line"<br/> pto1<br/> pto2<br/> ""<br/> )<br/> )<br/> (progn<br/> (setq pto1 (c:cal "(pta1+ptb1)/2")<br/> pto2 (c:cal "(pta2+ptb2)/2")<br/> )<br/> (command "_line"<br/> pto1<br/> pto2<br/> ""<br/> )<br/> )<br/> )<br/> (arxunload "geomcal.arx" nil)<br/> (setq objline (entlast)<br/> dd (distance pto1 pto2)<br/> )<br/> (setq adist (adddist))<br/> (command "_lengthen"<br/> "t"<br/> (+ dd adist)<br/> (cons objline (list pto1))<br/> ""<br/> )<br/> (command "_lengthen"<br/> "t"<br/> (+ dd (* adist 2))<br/> (cons objline (list pto2))<br/> ""<br/> )</p><p> ) ;px<br/> ) ;if 2<br/>)</p><p><br/>(defun sline_cl (en1 / ed1 pta1 pta2 pto anga ango adist pto1 pto2)<br/> (arxload "geomcal.arx" nil)<br/> (setq ed1 (entget en1))<br/> (setq pta1 (cdr (assoc 10 ed1))<br/> pta2 (cdr (assoc 11 ed1))</p><p> )<br/> (setq pto (c:cal "(pta1 + pta2) / 2"))<br/> (setq anga (angle pto pta1))<br/> (setq ango (+ anga (/ PI 2)))<br/> (setq adist (adddist))<br/> (setq pto1 (polar pto ango adist))<br/> (setq pto2 (polar pto ango (- adist)))<br/> (command "_line" pto1 pto2 "")<br/> (arxunload "geomcal.arx" nil)<br/>)</p><p>;画椭圆中心线<br/>(defun ellipse_cl (en1 / ss pc px rad rad1 d p1 p2 ri adist ns n lline)<br/> (setq ss (ssget '((0 . "Ellipse"))))</p><p>(setq ns (sslength ss) n 0)<br/> (<br/> while (< n ns)</p><p>(setq adist(adddist))<br/>(setq en1 (ssname ss n)) <br/>(setq pc (dxf 10 en1))<br/>(<br/> setq px (dxf 11 en1)<br/> px (list (+ (car pc)(car px))(+ (cadr pc)(cadr px)) 0)<br/> rad (distance pc px)<br/> d (/ (fix (* rad adist)) 100.0)<br/> p1 (polar pc (angle pc px)(+ rad d))<br/> p2 (polar pc (angle px pc)(+ rad d))<br/> rad1 (* (dxf 40 en1) rad)<br/> ri (/ (+ rad1 d)(+ rad d))<br/>) ;end setq</p><p>(if p2 (command "line" p1 p2 ""))<br/> (setq lline (entlast))<br/> (command "copy" (entlast) "" pc pc "rotate" (entlast) "" pc 90 "")<br/> (<br/>if (= (dxf 0 en1) "ELLIPSE") (command "scale" lline "" pc ri )<br/>);end if<br/> <br/> (setq n (1+ n))<br/> )<br/> (princ)<br/> <br/>)</p><p><br/>(defun dxf (code ename)(cdr (assoc code (entget ename))))</p><p>;主程序 <br/>(defun c:cline (/ oldlayer oldecho oldsnap oldortho en1 )<br/> (setq oldlayer (getvar "clayer"))<br/> (setq oldecho (getvar "cmdecho"))<br/> (setq oldsnap (getvar "osmode"))<br/> (setq oldortho (getvar "orthomode"))<br/> ;(setvar "clayer" "Center")<br/> (setvar "cmdecho" 0)<br/> (setvar "osmode" 0)<br/> (setvar "orthomode" 0)<br/> (setq en1 (car (entsel "\n请选择直线、圆、圆弧或椭圆<退出>:")))<br/> (if en1<br/> (cond<br/> ((= "LINE" (cdr (assoc 0 (entget en1)))) (line_cl en1))<br/> ((= "ARC" (cdr (assoc 0 (entget en1)))) (arc_cl en1))<br/> ((= "CIRCLE" (cdr (assoc 0 (entget en1)))) (circle_cl en1))<br/> ((= "ELLIPSE" (cdr (assoc 0 (entget en1)))) (ellipse_cl en1))<br/> (t (princ "\n所选对象不符合要求，程序退出"))<br/> )<br/> (princ "\n未选择对象，程序退出")<br/> )<br/> (setvar "cmdecho" oldecho)<br/> (setvar "osmode" oldsnap)<br/> (setvar "orthomode" oldortho)<br/> (setvar "clayer" oldlayer)<br/> (princ)<br/>)</p><p></p> 另外哪位大哥能否给这个程序再加个画矩形中心线的程序。在网上一直找不到这样的程序！先谢谢了。 顶上去，求各位老大帮帮忙呀。感谢你们了。 <p>我更改了ellipse_cl函数，你试度吧。</p><p>(defun ellipse_cl (en1 / ss pc px rad rad1 d p1 p2 ri adist ns n lline)<br/> (setq ss (ssget '((0 . "Ellipse"))))</p><p> (setq ns (sslength ss)<br/> n 0<br/> )<br/> (<br/> while (< n ns)</p><p> (setq adist (adddist))<br/> (setq en1 (ssname ss n))<br/> (setq pc (dxf 10 en1))<br/> (setq px (dxf 11 en1)<br/> px (list (+ (car pc) (car px)) (+ (cadr pc) (cadr px)) 0)<br/> rad (distance pc px)<br/> d (/ (fix (* rad adist)) 100.0)<br/> p1 (polar pc (angle pc px) (+ rad d))<br/> p2 (polar pc (angle px pc) (+ rad d))<br/> rad1 (* (dxf 40 en1) rad)<br/> ri (/ (+ rad1 d) (+ rad d))<br/> ) ;end setq</p><p> (if p2<br/> (command "line" p1 p2 "")<br/> )<br/> (command "copy"<br/> (entlast)<br/> ""<br/> pc<br/> pc<br/> "rotate"<br/> (entlast)<br/> ""<br/> pc<br/> 90<br/> )<br/> (setq lline (entlast))<br/> (if (= (dxf 0 en1) "ELLIPSE")<br/> (command "scale" lline "" pc ri)<br/> ) ;end if</p><p> (setq n (1+ n))<br/> )<br/> (princ)</p><p>)</p> <p>非常感谢,画椭圆中心线问题已经解决.太感谢你了,就是现在还没有画矩形中心线的程序.</p> 不知是哪位大侠编的，也忘了从哪找到的，可对矩形画中心线<br/>(defun c:CL ()<br/> (vl-load-com)<br/> (setq ent0 (car (entsel "\n 请选择直线、圆、圆弧、椭圆和矩形:")))<br/> (setq ent1 (entget ent0))<br/> (setq name (cdr (assoc 0 ent1)))<br/> (setq os (getvar "osmode"))<br/> (setq cmd (getvar "CMDECHO"))<br/> (setvar "cmdecho" 0)<br/> (setvar "OSMODE" 0)<br/>;;;所选物体是直线<br/> (cond ((= name "LINE")<br/> (setq ent2 (entget (car (entsel "\n 请选择另一条直线:"))))<br/> (setq point10 (cdr (assoc 10 ent1))<br/> point11 (cdr (assoc 11 ent1))<br/> point20 (cdr (assoc 10 ent2))<br/> point21 (cdr (assoc 11 ent2))<br/> ) ;_求两直线2个端点的坐标<br/> (setq ang1 (angle point10 point11)<br/> ang2 (angle point20 point21)<br/> )<br/> (if (or (equal (abs (- ang1 ang2)) pi 0.0001)<br/> (= (- ang1 ang2) 0)<br/> )<br/> (progn<br/> (setq obj (vlax-Ename->vla-object ent0))<br/> (setq p0 (vlax-curve-getClosestPointTo obj point20))<br/> (setq inter-point<br/> (mapcar '(lambda (a b) (/ (+ a b) 2))<br/> p0<br/> point20<br/> )<br/> )<br/> (print inter-point)<br/> (command "offset" "T" ent0 inter-point "")<br/> )<br/> (progn<br/> (setq inter-point (inters point10 point11 point20 point21 nil)) ;_求得两直线的交点<br/> (setq p0 (polar inter-point (angle inter-point point10) 10)<br/> p1 (polar inter-point (angle inter-point point20) 10)<br/> ) ;_求2个虚拟点<br/><br/> ;直线端点离交点最近判断<br/> (if (> (distance inter-point point10)<br/> (distance inter-point point11)<br/> )<br/> (setq p10 point11<br/> p11 point10<br/> )<br/> (setq p10 point10<br/> p11 point11<br/> )<br/> )<br/> (if (> (distance inter-point point20)<br/> (distance inter-point point21)<br/> )<br/> (setq p20 point21<br/> p21 point20<br/> )<br/> (setq p20 point20<br/> p21 point21<br/> )<br/> )<br/> ;求角平分线上的虚拟点<br/> (setq inter-point0<br/> (mapcar '(lambda (a b) (/ (+ a b) 2)) p0 p1)<br/> )<br/> (setq p00 (inters p10 p20 inter-point inter-point0 nil)<br/> p01 (inters p11 p21 inter-point inter-point0 nil)<br/> )<br/> (command "LINE" p00 p01 "")<br/> )<br/> )<br/> )<br/>;;;所选物体是圆<br/> ((or<br/> (= name "CIRCLE")<br/> (= name "ARC")<br/> )<br/> (setq point (cdr (assoc 10 ent1)))<br/> (setq r (cdr (assoc 40 ent1)))<br/> (setq l (+ r 2.0))<br/> (setq x (car point)<br/> y (cadr point)<br/> )<br/> (setq point10 (list (- x l) y))<br/> (setq point11 (list (+ x l) y))<br/> (setq point20 (list x (+ y l)))<br/> (setq point21 (list x (- y l)))<br/><br/><br/> (command "line" point10 point11 "")<br/> (command "line" point20 point21 "")<br/><br/><br/> )<br/><br/>;;;所选物体是圆弧<br/> ;;((= name "ARC")<br/> ;; )<br/><br/>;;;所选物体是椭圆<br/> ((= name "ELLIPSE")<br/> (setq obj (vlax-Ename->Vla-Object ent0))<br/> (setq center-point (vlax-safearray->list<br/> (vlax-variant-value (vla-get-Center obj))<br/> )<br/> StartPoint (vlax-safearray->list<br/> (vlax-variant-value (vla-get-StartPoint obj))<br/> )<br/> MajorRadius (vla-get-MajorRadius obj)<br/> MinorRadius (vla-get-MinorRadius obj)<br/> )<br/> (setq ang1 (angle center-point startpoint)<br/> ang2 (+ ang1 (* pi 0.5))<br/> )<br/> (setq point10 (polar center-point ang1 (+ MajorRadius 2.0))<br/> point11 (polar center-point<br/> (+ ang1 pi)<br/> (+ MajorRadius 2.0)<br/> )<br/> point20 (polar center-point ang2 (+ MinorRadius 2.0))<br/> point21 (polar center-point<br/> (+ ang2 pi)<br/> (+ MinorRadius 2.0)<br/> )<br/> )<br/> (command "LINE" point10 point11 "")<br/> (command "LINE" point20 point21 "")<br/> )<br/><br/>;;;所选物体是矩形 <br/> ((= name "LWPOLYLINE")<br/> (setq obj (vlax-Ename->Vla-Object ent0))<br/> (setq point (vlax-safearray->list<br/> (vlax-variant-value (vla-get-Coordinates obj))<br/> )<br/> )<br/> (if (= (length point) 8)<br/> (progn<br/><br/> (setq p1 (list (nth 0 point) (nth 1 point))<br/> p2 (list (nth 2 point) (nth 3 point))<br/> p3 (list (nth 4 point) (nth 5 point))<br/> p4 (list (nth 6 point) (nth 7 point))<br/> )<br/> (setq center-point (mapcar '(lambda (a b) (/ (+ a b) 2))<br/> p1<br/> p3<br/> )<br/> ang1 (angle p1 p2)<br/> ang2 (angle p1 p4)<br/> d1 (distance p1 p2)<br/> d2 (distance p1 p4)<br/> )<br/> (setq point10 (polar center-point ang1 (+ (* d1 0.5) 2.0))<br/> point11 (polar center-point<br/> (+ ang1 pi)<br/> (+ (* d1 0.5) 2.0)<br/> )<br/> point20 (polar center-point ang2 (+ (* d2 0.5) 2.0))<br/> point21 (polar center-point<br/> (+ ang2 pi)<br/> (+ (* d2 0.5) 2.0)<br/> )<br/> )<br/> (command "LINE" point10 point11 "")<br/> (command "LINE" point20 point21 "")<br/> )<br/> (princ "\n所选物体不是矩形,请重新选择!")<br/> )<br/> )<br/> (T<br/> (princ<br/> "\n 所选物体不属于直线、圆、圆弧、椭圆和矩形之内,请重新选择!"<br/> )<br/> )<br/> )<br/> (setvar "OSMODE" os)<br/> (setvar "cmdecho" cmd)<br/> (princ)<br/>)<br/> <p><strong><font face="Verdana" color="#61b713">太好了,我以前看到网站上有关于这一编程的流程思路,可惜一直没找到作者的源代码,</font></strong></p><p><strong><font face="Verdana" color="#61b713">ygrzz发了,今天让我遇到了,太好了,谢谢</font></strong></p> 可否再改进一下！颜色控制选择红色，线型控制选择中心线!就完美了！ 谢谢分享，非常感谢
页:
[1]