[求助]画中心线问题！

fengjunchina

从网上下载了一个画中心线的LISP程序

帮忙分析一下为什么画椭圆中心线的方向是反的。用在AutoCAD R14英文版下。源程序如下：

;;   本程序为绘制中心线程序
;;   执行命令：cline
;;
;;确定中心线延伸长度
;(defun adddist (/ defdist)
 ; (if dist
   ; (progn
    ;  (princ "\n请输入延伸长度<")
    ;  (setq defdist (princ dist))
     ; (setq dist (getdist ">:"))
    ;)
    ;(progn
      ;(setq defdist 5)

     ; (setq dist (getdist "\n请输入延伸长度<5>:"))
   ; )
 ; )
 ; (if (= dist nil)
  ;  (setq dist defdist)
 ; )
 ; dist
;)

;;确定中心线延伸长度
(defun adddist (/ dist scale)
(setq SCALE (getvar "DIMSCALE"))
   (setq DIST (* 3.5 SCALE))
)

;画圆中心线
(defun circle_cl (en1 / ss i j ent ents ptc r pts adist)
  (setq ss (ssget '((0 . "Circle"))))
  (setq i 0)
  (setq adist(adddist))
  (repeat (sslength ss)
  (setq ent (ssname ss i))
    (setq ents (entget ent))
    (setq ptc (cdr (assoc 10 ents))
   r (cdr (assoc 40 ents))
   j 0
   pts'())
    (repeat 4
      (setq pts (append pts (list (polar ptc (* j (/ pi 2)) (+ r adist)))))
      (setq j (1+ j))
    )
    (command "_.line" (nth 0 pts) (nth 2 pts) ""
      "_.line" (nth 1 pts) (nth 3 pts) "")
    (setq i (1+ i))
  )
  (princ)
 
)

;画弧中心线
(defun arc_cl (en1 / ed1 pto rad ang1 ang2 pto1 pt1 pt2 pto2 objline dd adist)
  (setq ed1 (entget en1))
  (setq pto  (cdr (assoc 10 ed1))
 rad  (cdr (assoc 40 ed1))
 ang1 (cdr (assoc 50 ed1))
 ang2 (cdr (assoc 51 ed1))
  )
  (if (> ang1 ang2)
    (setq ang2(+ ang2 (* PI 2)))
    )
  (setq ang (/ (+ ang1 ang2)2))
   (setq pto1 (polar pto ang rad))
  (setq pt1 (polar pto ang1 rad))
  (setq pt2 (polar pto ang2 rad))
  (setq pto2 (inters pto pto1 pt1 pt2 nil))
 (command "_line" pto1 pto2 "")
  (setq objline (entlast)
 dd (distance pto1 pto2)
  )
  (setq adist (adddist))
  (command "_lengthen"
    "t"
    (+ dd adist)
    (cons objline (list pto1))
    ""
  )
  (command "_lengthen"
    "t"
    (+ dd (* adist 2))
    (cons objline (list pto2))
    ""
  )

)

;画直线中心线
(defun line_cl (en1 / en2 )
  (setq en2 (car (entsel "\n请选择另外的直线<只绘制单直线中心线>:")))
  (if en2
    (progn
      (while (/= "LINE" (cdr (assoc 0 (entget en2))))
 (setq en2 (car (entsel "\n请重新选择另外的直线:")))
      )
      (dline_cl en1 en2)
    )
    (sline_cl en1)
  )
)

(defun dline_cl (en1 en2 /   ed1     ed2     pta1    pta2    ptb1
       ptb2    pto     ptoo    pto1    pto2    anga
       angb    ango    objline dd      adist)
  (setq ed1 (entget en1)
 ed2 (entget en2)
  )
  (setq pta1 (cdr (assoc 10 ed1))
 pta2 (cdr (assoc 11 ed1))
 ptb1 (cdr (assoc 10 ed2))
 ptb2 (cdr (assoc 11 ed2))
  )

  (if (setq pto (inters pta1 pta2 ptb1 ptb2 nil)) ;if 2
    (if (inters pta1 pta2 ptb1 ptb2) ;if 3
      (princ "\n两线相交，退出")
      (progn
 (setq anga (angle pto pta1)
       angb (angle pto ptb1)
       ango (/ (+ anga angb) 2)
       ptoo (polar pto ango 1)
 )    ;setq
 (if (inters pta1 ptb1 pta2 ptb2) ;if 4
   (setq pto1 (inters pta1 ptb2 pto ptoo nil)
  pto2 (inters pta2 ptb1 pto ptoo nil)
   )
   (setq pto1 (inters pta1 ptb1 pto ptoo nil)
  pto2 (inters pta2 ptb2 pto ptoo nil)
   )
 )    ;if 4
 (command "_line" pto1 pto2 "")
 (setq objline (entlast)
       dd      (distance pto1 pto2)
 )
 (setq adist (adddist))
 (command "_lengthen"
   "t"
   (+ dd adist)
   (cons objline (list pto1))
   ""
 )
 (command "_lengthen"
   "t"
   (+ dd (* adist 2))
   (cons objline (list pto2))
   ""
 )

      )     ;progn
    )     ;if 3
    (progn
      (arxload "geomcal.arx" nil)
      (if (inters pta1 ptb1 pta2 ptb2) ;if 4
 (progn
   (setq pto1 (c:cal "(pta1 + ptb2) / 2")
  pto2 (c:cal "(pta2 + ptb1) / 2")
   )
   (command "_line"
     pto1
     pto2
     ""
   )
 )
 (progn
   (setq pto1 (c:cal "(pta1+ptb1)/2")
  pto2 (c:cal "(pta2+ptb2)/2")
   )
   (command "_line"
     pto1
     pto2
     ""
   )
 )
      )
      (arxunload "geomcal.arx" nil)
      (setq objline (entlast)
     dd     (distance pto1 pto2)
      )
      (setq adist (adddist))
      (command "_lengthen"
        "t"
        (+ dd adist)
        (cons objline (list pto1))
        ""
      )
      (command "_lengthen"
        "t"
        (+ dd (* adist 2))
        (cons objline (list pto2))
        ""
      )

    )     ;px
  )     ;if 2
)

(defun sline_cl (en1 / ed1 pta1 pta2 pto anga ango adist pto1 pto2)
  (arxload "geomcal.arx" nil)
  (setq ed1 (entget en1))
  (setq pta1 (cdr (assoc 10 ed1))
 pta2 (cdr (assoc 11 ed1))

  )
  (setq pto (c:cal "(pta1 + pta2) / 2"))
  (setq anga (angle pto pta1))
  (setq ango (+ anga (/  PI 2)))
  (setq adist (adddist))
  (setq pto1 (polar pto ango adist))
  (setq pto2 (polar pto ango (- adist)))
  (command "_line" pto1 pto2 "")
  (arxunload "geomcal.arx" nil)
)

;画椭圆中心线
(defun ellipse_cl (en1 / ss pc px rad rad1 d p1 p2 ri adist ns n lline)
  (setq ss (ssget '((0 . "Ellipse"))))

(setq ns (sslength ss) n 0)
  (
 while (< n ns)

(setq adist(adddist))
(setq en1 (ssname ss n)) 
(setq pc (dxf 10 en1))
(
    setq px (dxf 11 en1)
       px (list (+ (car pc)(car px))(+ (cadr pc)(cadr px)) 0)
      rad (distance pc px)
        d (/ (fix (* rad adist)) 100.0)
       p1 (polar pc (angle pc px)(+ rad d))
              p2 (polar pc (angle px pc)(+ rad d))
            rad1 (* (dxf 40 en1) rad)
              ri (/ (+ rad1 d)(+ rad d))
) ;end setq

(if p2 (command "line" p1 p2 ""))
    (setq lline (entlast))
    (command "copy" (entlast) "" pc pc "rotate" (entlast) "" pc 90 "")
    (
if (= (dxf 0 en1) "ELLIPSE") (command "scale" lline "" pc ri )
);end if
 
    (setq n (1+ n))
  )
  (princ)
 
)

(defun dxf (code ename)(cdr (assoc code (entget ename))))

;主程序
(defun c:cline (/ oldlayer oldecho oldsnap oldortho en1 )
  (setq oldlayer (getvar "clayer"))
  (setq oldecho (getvar "cmdecho"))
  (setq oldsnap (getvar "osmode"))
  (setq oldortho (getvar "orthomode"))
  ;(setvar "clayer" "Center")
  (setvar "cmdecho" 0)
  (setvar "osmode" 0)
  (setvar "orthomode" 0)
  (setq en1 (car (entsel "\n请选择直线、圆、圆弧或椭圆<退出>:")))
  (if en1
    (cond
      ((= "LINE" (cdr (assoc 0 (entget en1)))) (line_cl en1))
      ((= "ARC" (cdr (assoc 0 (entget en1)))) (arc_cl en1))
      ((= "CIRCLE" (cdr (assoc 0 (entget en1)))) (circle_cl en1))
      ((= "ELLIPSE" (cdr (assoc 0 (entget en1)))) (ellipse_cl en1))
      (t (princ "\n所选对象不符合要求，程序退出"))
    )
    (princ "\n未选择对象，程序退出")
  )
  (setvar "cmdecho" oldecho)
  (setvar "osmode" oldsnap)
  (setvar "orthomode" oldortho)
  (setvar "clayer" oldlayer)
  (princ)
)

fengjunchina

另外哪位大哥能否给这个程序再加个画矩形中心线的程序。在网上一直找不到这样的程序！先谢谢了。

fengjunchina

顶上去，求各位老大帮帮忙呀。感谢你们了。

bobby

我更改了ellipse_cl函数，你试度吧。

(defun ellipse_cl (en1 / ss pc px rad rad1 d p1 p2 ri adist ns n lline)
  (setq ss (ssget '((0 . "Ellipse"))))

  (setq ns (sslength ss)
 n  0
  )
  (
   while (< n ns)

    (setq adist (adddist))
    (setq en1 (ssname ss n))
    (setq pc (dxf 10 en1))
    (setq px   (dxf 11 en1)
   px   (list (+ (car pc) (car px)) (+ (cadr pc) (cadr px)) 0)
   rad  (distance pc px)
   d    (/ (fix (* rad adist)) 100.0)
   p1   (polar pc (angle pc px) (+ rad d))
   p2   (polar pc (angle px pc) (+ rad d))
   rad1 (* (dxf 40 en1) rad)
   ri   (/ (+ rad1 d) (+ rad d))
    )     ;end setq

    (if p2
      (command "line" p1 p2 "")
    )
    (command "copy"
      (entlast)
      ""
      pc
      pc
      "rotate"
      (entlast)
      ""
      pc
      90
    )
    (setq lline (entlast))
    (if (= (dxf 0 en1) "ELLIPSE")
      (command "scale" lline "" pc ri)
    )     ;end if

    (setq n (1+ n))
  )
  (princ)

)

fengjunchina

非常感谢,画椭圆中心线问题已经解决.太感谢你了,就是现在还没有画矩形中心线的程序.

ygrzz

不知是哪位大侠编的，也忘了从哪找到的，可对矩形画中心线
(defun c:CL ()
  (vl-load-com)
  (setq ent0 (car (entsel "\n 请选择直线、圆、圆弧、椭圆和矩形:")))
  (setq ent1 (entget ent0))
  (setq name (cdr (assoc 0 ent1)))
  (setq os (getvar "osmode"))
  (setq cmd (getvar "CMDECHO"))
  (setvar "cmdecho" 0)
  (setvar "OSMODE" 0)
;;;所选物体是直线
  (cond    ((= name "LINE")
     (setq ent2 (entget (car (entsel "\n 请选择另一条直线:"))))
     (setq point10 (cdr (assoc 10 ent1))
           point11 (cdr (assoc 11 ent1))
           point20 (cdr (assoc 10 ent2))
           point21 (cdr (assoc 11 ent2))
     ) ;_求两直线2个端点的坐标
     (setq ang1 (angle point10 point11)
           ang2 (angle point20 point21)
     )
     (if (or (equal (abs (- ang1 ang2)) pi 0.0001)
         (= (- ang1 ang2) 0)
         )
       (progn
         (setq obj (vlax-Ename->vla-object ent0))
         (setq p0 (vlax-curve-getClosestPointTo obj point20))
         (setq inter-point
            (mapcar '(lambda (a b) (/ (+ a b) 2))
                p0
                point20
            )
         )
         (print inter-point)
         (command "offset" "T" ent0 inter-point "")
       )
       (progn
         (setq inter-point (inters point10 point11 point20 point21 nil)) ;_求得两直线的交点
         (setq p0 (polar inter-point (angle inter-point point10) 10)
           p1 (polar inter-point (angle inter-point point20) 10)
         ) ;_求2个虚拟点

                    ;直线端点离交点最近判断
         (if (> (distance inter-point point10)
            (distance inter-point point11)
         )
           (setq p10 point11
             p11 point10
           )
           (setq p10 point10
             p11 point11
           )
         )
         (if (> (distance inter-point point20)
            (distance inter-point point21)
         )
           (setq p20 point21
             p21 point20
           )
           (setq p20 point20
             p21 point21
           )
         )
                    ;求角平分线上的虚拟点
         (setq inter-point0
            (mapcar '(lambda (a b) (/ (+ a b) 2)) p0 p1)
         )
         (setq p00 (inters p10 p20 inter-point inter-point0 nil)
           p01 (inters p11 p21 inter-point inter-point0 nil)
         )
         (command "LINE" p00 p01 "")
       )
     )
    )
;;;所选物体是圆
    ((or
       (= name "CIRCLE")
       (= name "ARC")
     )
     (setq point (cdr (assoc 10 ent1)))
     (setq r (cdr (assoc 40 ent1)))
     (setq l (+ r 2.0))
     (setq x (car point)
           y (cadr point)
     )
     (setq point10 (list (- x l) y))
     (setq point11 (list (+ x l) y))
     (setq point20 (list x (+ y l)))
     (setq point21 (list x (- y l)))


     (command "line" point10 point11 "")
     (command "line" point20 point21 "")


    )

;;;所选物体是圆弧
    ;;((= name "ARC")
    ;;    )

;;;所选物体是椭圆
    ((= name "ELLIPSE")
     (setq obj (vlax-Ename->Vla-Object ent0))
     (setq center-point (vlax-safearray->list
                  (vlax-variant-value (vla-get-Center obj))
                )
           StartPoint   (vlax-safearray->list
                  (vlax-variant-value (vla-get-StartPoint obj))
                )
           MajorRadius  (vla-get-MajorRadius obj)
           MinorRadius  (vla-get-MinorRadius obj)
     )
     (setq ang1 (angle center-point startpoint)
           ang2 (+ ang1 (* pi 0.5))
     )
     (setq point10 (polar center-point ang1 (+ MajorRadius 2.0))
           point11 (polar center-point
                  (+ ang1 pi)
                  (+ MajorRadius 2.0)
               )
           point20 (polar center-point ang2 (+ MinorRadius 2.0))
           point21 (polar center-point
                  (+ ang2 pi)
                  (+ MinorRadius 2.0)
               )
     )
     (command "LINE" point10 point11 "")
     (command "LINE" point20 point21 "")
    )

;;;所选物体是矩形   
    ((= name "LWPOLYLINE")
     (setq obj (vlax-Ename->Vla-Object ent0))
     (setq point (vlax-safearray->list
               (vlax-variant-value (vla-get-Coordinates obj))
             )
     )
     (if (= (length point) 8)
       (progn

         (setq p1 (list (nth 0 point) (nth 1 point))
           p2 (list (nth 2 point) (nth 3 point))
           p3 (list (nth 4 point) (nth 5 point))
           p4 (list (nth 6 point) (nth 7 point))
         )
         (setq center-point    (mapcar    '(lambda (a b) (/ (+ a b) 2))
                    p1
                    p3
                )
           ang1        (angle p1 p2)
           ang2        (angle p1 p4)
           d1        (distance p1 p2)
           d2        (distance p1 p4)
         )
         (setq point10 (polar center-point ang1 (+ (* d1 0.5) 2.0))
           point11 (polar center-point
                  (+ ang1 pi)
                  (+ (* d1 0.5) 2.0)
               )
           point20 (polar center-point ang2 (+ (* d2 0.5) 2.0))
           point21 (polar center-point
                  (+ ang2 pi)
                  (+ (* d2 0.5) 2.0)
               )
         )
         (command "LINE" point10 point11 "")
         (command "LINE" point20 point21 "")
       )
       (princ "\n所选物体不是矩形,请重新选择!")
     )
    )
    (T
     (princ
       "\n 所选物体不属于直线、圆、圆弧、椭圆和矩形之内,请重新选择!"
     )
    )
  )
  (setvar "OSMODE" os)
  (setvar "cmdecho" cmd)
  (princ)
)

usestone

太好了,我以前看到网站上有关于这一编程的流程思路,可惜一直没找到作者的源代码,

ygrzz发了,今天让我遇到了,太好了,谢谢

长枫间谍

可否再改进一下！颜色控制选择红色，线型控制选择中心线!就完美了！

库里

谢谢分享，非常感谢