快速绘制指定长度的样条曲线

dcl1214 · 发表于 2023-10-11 11:16:53

本帖最后由 dcl1214 于 2023-10-11 11:22 编辑

;绘制样条曲线
(vl-doc-export '$c:hzytxrun$)
(defun $c:hzytxrun$ (lst / $make-spline$
*error* dxf en ents
ent-spline l l-all line-jzx
line-jzx-ent line-jzx-p2
mark obj pt pts
pts-sd tmp
)
(defun *error* (s)
(if (and mark (entget mark))
(entdel mark)
)
)
(defun $make-Spline$ (ptn / a)
(entmakex
(append (list '(0 . "SPLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbSpline")
'(71 . 3)
)
(mapcar (function (lambda (pt) (cons 11 pt))) ptn)
)
)
)
(SETQ L-ALL (GETREAL "请输入样条曲线的总长度"))
(if (and L-ALL (> L-ALL 0.5))
(progn
(setq
pt (getpoint
"点击鼠标左键开始绘制样条曲线\n连续敲两次空格结束绘制"
)
)
(if pt
(progn
(setq pts nil)
(setq pts (append pts (list pt)))
(if pt
(progn
(setq
mark (VLAX-VLA-OBJECT->ENAME
(VLA-ADDPOINT
(vla-get-ModelSpace
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
(VLAX-3D-POINT (LIST 0 0 0))
)
)
)
(vl-cmdf "_.spline" "non" pt)
;(setq ent (entlast))
(while (= 1 (logand 1 (getvar 'cmdactive)))
(vl-cmdf "\\")
(setq pts (append pts (list (getvar 'lastpoint))))
(SETQ TMP NIL)
(AND (setq tmp ($make-Spline$ pts))
(SETQ OBJ (VLAX-ENAME->VLA-OBJECT TMP))
(setq
L (vlax-curve-getDistAtPoint
OBJ
(vlax-curve-getEndPoint OBJ)
)
)
)
(and tmp (entget tmp) (entdel tmp))
(IF (>= L L-ALL)
(PROGN
(if (= 1 (logand 1 (getvar 'cmdactive)))
(progn (VL-CMDF "") (VL-CMDF "") (VL-CMDF ""))
)
)
)
(print L)
)
(and ent (setq dxf (entget ent '("*"))))
)
)
(setq en mark)
(setq ents nil)
(while (setq en (entnext en))
(if (and en (entget en))
(setq ents (append ents (list en)))
)
) ;用en循环获取后添加到ents记录里面
(if (and mark (entget mark))
(entdel mark)
)
(setq en nil)
(setq ent-spline (car ents))
(if (and ent-spline (entget ent-spline))
(progn
(and kuozhanshuju(kuozhanshuju
ent-spline
"length"
(list (vl-princ-to-string L-ALL))
"ALL"
))
(setq obj (vlax-ename->vla-object ent-spline))
(setq pts-sd (vlax-curve-getPointAtDist obj L-ALL))
(setq line-jzx-p2
(polar (vlax-curve-getPointAtDist obj L-ALL)
(+ (angle (vlax-curve-getPointAtDist
obj
(* L-ALL 0.99)
)
(vlax-curve-getPointAtDist
obj
(* L-ALL 1.01)
)
)
(* pi 0.5)
)
1
)
)
(setq line-jzx (vla-addLine
(vla-Get-ModelSpace
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
(vlax-3D-Point
(vlax-curve-getPointAtDist obj L-ALL)
)
(vlax-3D-Point line-jzx-p2)
)
)
(setq line-jzx-ent (vlax-vla-object->ename line-jzx))
(VL-CMDF
"TRIM"
line-jzx-ent
""
(LIST ent-spline
(vlax-curve-getPointAtDist obj (* L-ALL 1.0125))
)
""
) ;(vlax-curve-getPointAtDist obj (* L-ALL 1.0125))
(entdel line-jzx-ent)
)
)
)
)
)
)
)
(defun c:hzytx () ($c:hzytxrun$ nil))

;绘制样条曲线 
(vl-doc-export '$c:hzytxrun$) 
(defun $c:hzytxrun$ (lst  /     $make-spline$ 
         *error*  dxf     en        ents 
         ent-spline  l     l-all      line-jzx 
         line-jzx-ent     line-jzx-p2 
         mark  obj     pt        pts 
         pts-sd  tmp 
        ) 
  (defun *error* (s) 
    (if  (and mark (entget mark)) 
      (entdel mark) 
    ) 
  ) 
  (defun $make-Spline$ (ptn / a) 
    (entmakex 
      (append (list '(0 . "SPLINE") 
        '(100 . "AcDbEntity") 
        '(100 . "AcDbSpline") 
        '(71 . 3) 
        ) 
        (mapcar (function (lambda (pt) (cons 11 pt))) ptn) 
      ) 
    ) 
  ) 
  (SETQ L-ALL (GETREAL "请输入样条曲线的总长度")) 
  (if (and L-ALL (> L-ALL 0.5)) 
    (progn 
      (setq 
  pt (getpoint 
       "点击鼠标左键开始绘制样条曲线\n连续敲两次空格结束绘制" 
     ) 
      ) 
      (if pt 
  (progn 
    (setq pts nil) 
    (setq pts (append pts (list pt))) 
    (if pt 
      (progn 
        (setq 
    mark (VLAX-VLA-OBJECT->ENAME 
           (VLA-ADDPOINT 
       (vla-get-ModelSpace 
         (vla-get-ActiveDocument 
           (vlax-get-acad-object) 
         ) 
       ) 
       (VLAX-3D-POINT (LIST 0 0 0)) 
           ) 
         ) 
        ) 
        (vl-cmdf "_.spline" "non" pt) 
          ;(setq ent (entlast)) 
        (while (= 1 (logand 1 (getvar 'cmdactive))) 
    (vl-cmdf "\\") 
    (setq pts (append pts (list (getvar 'lastpoint)))) 
    (SETQ TMP NIL) 
    (AND (setq tmp ($make-Spline$ pts)) 
         (SETQ OBJ (VLAX-ENAME->VLA-OBJECT TMP)) 
         (setq 
           L (vlax-curve-getDistAtPoint 
         OBJ 
         (vlax-curve-getEndPoint OBJ) 
       ) 
         ) 
    ) 
    (and tmp (entget tmp) (entdel tmp)) 
    (IF (>= L L-ALL) 
      (PROGN 
        (if  (= 1 (logand 1 (getvar 'cmdactive))) 
          (progn (VL-CMDF "") (VL-CMDF "") (VL-CMDF "")) 
        ) 
      ) 
    ) 
    (print L) 
        ) 
        (and ent (setq dxf (entget ent '("*")))) 
      ) 
    ) 
    (setq en mark) 
    (setq ents nil) 
    (while (setq en (entnext en)) 
      (if  (and en (entget en)) 
        (setq ents (append ents (list en))) 
      ) 
    )        ;用en循环获取后添加到ents记录里面 
    (if (and mark (entget mark)) 
      (entdel mark) 
    ) 
    (setq en nil) 
    (setq ent-spline (car ents)) 
    (if (and ent-spline (entget ent-spline)) 
      (progn 
        (and kuozhanshuju(kuozhanshuju 
    ent-spline 
    "length" 
    (list (vl-princ-to-string L-ALL)) 
    "ALL" 
        )) 
        (setq obj (vlax-ename->vla-object ent-spline)) 
        (setq pts-sd (vlax-curve-getPointAtDist obj L-ALL)) 
        (setq line-jzx-p2 
         (polar (vlax-curve-getPointAtDist obj L-ALL) 
          (+ (angle (vlax-curve-getPointAtDist 
          obj 
          (* L-ALL 0.99) 
              ) 
              (vlax-curve-getPointAtDist 
          obj 
          (* L-ALL 1.01) 
              ) 
             ) 
             (* pi 0.5) 
          ) 
          1 
         ) 
        ) 
        (setq line-jzx (vla-addLine 
             (vla-Get-ModelSpace 
         (vla-get-ActiveDocument 
           (vlax-get-acad-object) 
         ) 
             ) 
             (vlax-3D-Point 
         (vlax-curve-getPointAtDist obj L-ALL) 
             ) 
             (vlax-3D-Point line-jzx-p2) 
           ) 
        ) 
        (setq line-jzx-ent (vlax-vla-object->ename line-jzx)) 
        (VL-CMDF 
    "TRIM" 
    line-jzx-ent 
    "" 
    (LIST ent-spline 
          (vlax-curve-getPointAtDist obj (* L-ALL 1.0125)) 
    ) 
    "" 
        )        ;(vlax-curve-getPointAtDist obj (* L-ALL 1.0125)) 
        (entdel line-jzx-ent) 
      ) 
    ) 
  ) 
      ) 
    ) 
  ) 
) 
(defun c:hzytx () ($c:hzytxrun$ nil))

菜卷鱼 · 发表于 2023-10-11 16:18:00

中文变量名，不常见啊

panliang9 · 发表于 2023-10-12 08:52:31

谢谢楼主分享！

账号		自动登录	找回密码
密码			注册

[源码] 快速绘制指定长度的样条曲线

评分