[LISP程序]：发一个生成过渡曲线的程序

kingofrpg

[php]
(vl-load-com)
(defun c:tc (/ IsCurve ent1 ent2 pt1 pt2 p11 p12 p21 p22 start end obj1 obj2
               osmode
            )                               ; Check an entity is a curve or not
  (defun IsCurve (ename / name)
    (if ename
      (progn
        (setq name (cdr (assoc 0 (entget ename))))
        (cond
          ((= name "LWPOLYLINE")
            T
          )
          ((= name "POLYLINE")
            T
          )
          ((= name "CIRCLE")
            T
          )
          ((= name "ARC")
            T
          )
          ((= name "LINE")
            T
          )
          ((= name "ELLIPSE")
            T
          )
          ((= name "SPLINE")
            T
          )
          (T
            NIL
          )
        )
      )
      NIL
    )
  )

  ;; Main Program
  (setvar "cmdecho" 0)
  (vl-cmdf "_.undo" "g")
  (setq osmode (getvar "osmode"))
  (setvar "osmode" 0)
  (setq ent1 (entsel "选择第一条曲线："))
  (if (IsCurve (car ent1))
    (progn
      (if (IsCurve (car (setq ent2 (entsel "\n选择第二条曲线："))))
        (progn
          (setq pt1 (cadr ent1)
                obj1 (vlax-ename->vla-object (car ent1))
                pt2 (cadr ent2)
                obj2 (vlax-ename->vla-object (car ent2))
          )
          (setq start (vlax-curve-getstartpoint obj1)
                end (vlax-curve-getendpoint obj1)
          )
          (if (< (distance start pt1) (distance end pt1))
            (setq p11 start
                  p12 (vlax-curve-getfirstderiv obj1
                                                (vlax-curve-getstartparam obj1)
                      )
                  p12 (mapcar
                        '+
                        p11
                        p12
                      )
            )
            (setq p11 end
                  p12 (vlax-curve-getfirstderiv obj1
                                                (vlax-curve-getendparam obj1)
                      )
                  p12 (mapcar
                        '-
                        p11
                        p12
                      )
            )
          )
          (setq start (vlax-curve-getstartpoint obj2)
                end (vlax-curve-getendpoint obj2)
          )
          (if (< (distance start pt2) (distance end pt2))
            (setq p21 start
                  p22 (vlax-curve-getfirstderiv obj2
                                                (vlax-curve-getstartparam obj2)
                      )
                  p22 (mapcar
                        '+
                        p21
                        p22
                      )
            )
            (setq p21 end
                  p22 (vlax-curve-getfirstderiv obj2
                                                (vlax-curve-getendparam obj2)
                      )
                  p22 (mapcar
                        '-
                        p21
                        p22
                      )
            )
          )
          (vl-cmdf "_.spline" p11 p21 "" p12 p22)
        )
      )
    )
  )
  (setvar "osmode" osmode)
  (vl-cmdf "_.undo" "e")
)
[/php]