曲线展点

Gray-wolf 发表于 2018-6-4 00:28:37

(defun c:zd (/ en en_obj gd len len_lst obj pt pt_x pt_y pt1 pts ss ss1_lst)
(vl-load-com)
(setq eh-*error*-bak *error*)
(defun *error* (msg)
(setq *error* eh-*error*-bak)
(setvar "osmode" eh_os_g)
(vla-endundomark eh_doc_g)
(setvar "nomutt" 0)
(setvar "cmdecho" 1)
(print msg)
)

(setvar "cmdecho" 0)
(if (null eh_doc_g)(setq eh_doc_g (vla-get-activedocument (vlax-get-acad-object))))
(vla-startundomark eh_doc_g)
(if (< (setq eh_os_g (getvar "osmode")) 16384)
(setvar "osmode" (+ eh_os_g 16384))
)

(setq ss (ssget))
(setq en (ssname ss 0))
(setq en_obj (vlax-ename->vla-object en))
(setq ss1_lst (EH-SS->List (ssget)))
(setq ss1_lst (vl-remove en ss1_lst))
;;闭合对象取结束端点时出现长度0,所以取用参数来取长度
(setq len (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))
;;求出交点集
(setq pts '())
(foreach x ss1_lst
(setq obj (vlax-ename->vla-object x))
(setq pt (vla-IntersectWith en_obj obj acExtendNone))
(setq pt (vlax-variant-value pt))
(if (= -1 (vlax-safearray-get-u-bound pt 1))
nil
(progn
(setq pt (vlax-safearray->list pt))
;;如果交点在顶点上有可能会出错
;;(1.41138e+006 43846.0 0.0 1.41138e+006 43846.0 0.0)
(cond
((= (length pt) 3) (setq pts (cons pt pts)))
((> (length pt) 3)
(setq ls_lst nil)
(while (car pt)
(setq ls_lst (cons (list (car pt) (cadr pt) (caddr pt)) ls_lst))
(setq pt (cdr (cdr (cdr pt))))
)
(foreach x ls_lst
(setq pts (cons x pts))
)
)
(T nil)
)
)
)
)

;;求曲线上起点到各交点的长度并排序
(setq len_lst '())
(setq len_lst (cons len len_lst))
(foreach x pts
(setq len (vlax-curve-getDistAtPoint en x))
(setq len_lst (cons len len_lst))
)
(setq len_lst
(vl-sort len_lst '(lambda (a b) (< a b)))
)

(if len_lst
(progn

(if (= eh_wall_gd_g nil)
(setq eh_wall_gd_g 2900))
(princ "\n请输入墙高<")(princ eh_wall_gd_g)(princ ">:");;显示默认墙高
(setq gd (getdist))
(if (= gd nil)
(setq gd eh_wall_gd_g)
(setq eh_wall_gd_g gd))

(setvar "osmode" eh_os_g)
(setq pt1 (getpoint "请指定墙料插入点："))

(if (< (setq eh_os_g (getvar "osmode")) 16384)
(setvar "osmode" (+ eh_os_g 16384))
)
(setq pt_X (car pt1))
(setq pt_Y (cadr pt1))

(setq pts (list
pt1
(list (+ pt_X (last len_lst)) pt_Y)
(list (+ pt_X (last len_lst)) (+ pt_Y gd))
(list pt_X (+ pt_Y gd))
)
)
(EH-Make-Lwpolyline pts nil T nil nil)

(setq len_lst (reverse (cdr (reverse len_lst))))

(foreach x len_lst
(setq pts (list
(list (+ pt_X x) pt_Y)
(list (+ pt_X x) (+ pt_Y gd))
)
)
(EH-Make-Lwpolyline pts nil nil nil nil)
)
)
)

(setq *error* eh-*error*-bak)
(setvar "osmode" eh_os_g)
(vla-endundomark eh_doc_g)
(setvar "nomutt" 0)
(setvar "cmdecho" 1)
(princ)
);defun_end

lisperado 发表于 2018-10-8 16:04:12

本帖最后由 lisperado 于 2018-10-8 16:15 编辑

暂时用 EXPRESS TOOL代替看看？
(setq EH-SS->List ACET-SS-TO-LIST)

EH-Make-Lwpolyline这函数需要5个参数所以没办法帮
如果用普通线看看结果是什么？
(defun Make-Lwpolyline (lst)
(entmake (vl-list*    '(0 . "LWPOLYLINE")
                     '(100 . "AcDbEntity")
                     '(100 . "AcDbPolyline")
                     '(70 . 0)
                     (cons 90 (length lst))
                     (mapcar '(lambda (x) (cons 10 x)) lst)
                     )
         )
)

；搜索放弃应用无知EH-函数
(EH-Make-Lwpolyline pts nil nil nil nil)

；改普通线看看
(make-Lwpolyline pts)

lisperado 发表于 2018-10-14 10:39:25

可能你没安装ET?
虽然没有EH-SS->List函数也不清楚其功能，所以只能猜测罢了！
只有要求版主重发！

试试另一个函数？请先置顶看看
(defun ss->lst ( s / e)
(if (and s (setq e (ssname s 0))) (cons e (ss->lst (ssdel e s)))))
(setq EH-SS->List ss->lst)

预知幸福 发表于 2018-10-6 10:38:03

fangmin723 发表于 2018-6-4 07:50
缺少自定义函数：EH-SS->List和EH-Make-Lwpolyline

可以上传缺少的自定义函数：EH-SS->List和EH-Make-Lwpolyline吗

fangmin723 发表于 2018-6-4 07:50:33

缺少自定义函数：EH-SS->List和EH-Make-Lwpolyline

fangmin723 发表于 2018-10-7 07:38:07

预知幸福发表于 2018-10-6 10:38
可以上传缺少的自定义函数：EH-SS->List和EH-Make-Lwpolyline吗

这个程序不是我写的，这两个函数我没有!

预知幸福 发表于 2018-10-7 10:17:50

用不了可以把完整的代码补全吗

预知幸福 发表于 2018-10-7 10:27:38

用不了可以把完整的代码补全吗

预知幸福 发表于 2018-10-7 10:30:05

用不了可以把代码补全吗

hhh454 发表于 2018-10-8 16:55:16

感觉楼主的代码用建筑模型绘图

预知幸福 发表于 2018-10-11 11:57:36

hhh454 发表于 2018-10-8 16:55
感觉楼主的代码用建筑模型绘图

可以用在建筑模型绘图

页: [1] 2

明经CAD社区's Archiver

曲线展点