yang686526

请帮忙解决以下这个程序不能运行的问题,谢谢
www.dimcax.com
请帮忙解决以下这个程序不能运行的问题,谢谢
(defun c:tsk001 () (defun c:tsk001 ()
(prompt "\n **<日期:2007-07-14.tsk001>**") (prompt "\n **<日期:2007-07-14.tsk001>**")
(prompt "\n **<用途:圖塊中心點連線>**") (prompt "\n **<用途:图块中心点连线>**")
(command "undo" "be") (command "undo" "be")
;;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(print "選取連線圖塊...") (print "选取连线图块...")
(setq s1 (ssget (list (cons 2 "12")) )) ;;圖塊名稱請自行命名設定 (setq s1 (ssget (list (cons 2 "12")) )) ;;图块名称请自行命名设定
(setq i 0) (setq i 0)
(setq pt_s1 nil) (setq pt_s1 nil)
(repeat (sslength s1) (repeat (sslength s1)
(setq en (ssname s1 i)) (setq en (ssname s1 i))
(setq vla_en (vlax-ename->vla-object en)) (setq vla_en (vlax-ename->vla-object en))
(setq pt_s1 (append pt_s1 (list (vlax-get vla_en 'insertionpoint) ))) (setq pt_s1 (append pt_s1 (list (vlax-get vla_en 'insertionpoint) )))
(setq i (1+ i)) (setq i (1+ i))
)
;;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(print "選取連線基準圖塊...") (print "选取连线基准图块...")
(setq s2 (ssget (list (cons 2 "12")) )) ;;圖塊名稱請自行命名設定 (setq s2 (ssget (list (cons 2 "12")) )) ;;图块名称请自行命名设定
(setq i 0) (setq i 0)
(setq pt_s2 nil) (setq pt_s2 nil)
(repeat (sslength s2) (repeat (sslength s2)
(setq en (ssname s2 i)) (setq en (ssname s2 i))
(setq vla_en (vlax-ename->vla-object en)) (setq vla_en (vlax-ename->vla-object en))
(setq pt_s2 (append pt_s2 (list (vlax-get vla_en 'insertionpoint) ))) (setq pt_s2 (append pt_s2 (list (vlax-get vla_en 'insertionpoint) )))
(setq i (1+ i)) (setq i (1+ i))
)
(princ "\n 提示排序方式: e配a , c配b ...") (princ "\n提示排序方式: e配a , c配b ...")
(setq pt_s1 (sort_type8_pt_list pt_s1)) ;e配a (setq pt_s1 (sort_type8_pt_list pt_s1)) ;e配a
(setq pt_s2 (sort_type8_pt_list pt_s2)) (setq pt_s2 (sort_type8_pt_list pt_s2))
(setq e 0) (setq e 0)
(repeat (1- (length pt_s2)) (repeat (1- (length pt_s2))
(setq pt_s2-x (nth e pt_s2) (setq pt_s2-x (nth e pt_s2)
pt_s2-y (nth (1+ e) pt_s2) pt_s2-y (nth (1+ e) pt_s2)
) ;_ 結束setq ) ;_结束setq
(command "_line" pt_s2-x pt_s2-y "") (command "_line" pt_s2-x pt_s2-y "")
(setq e (1+ e)) (setq e (1+ e))
)
(setq i 0) (setq i 0)
(repeat (length pt_s2) (repeat (length pt_s2)
(setq pt_xt (nth i pt_s2)) (setq pt_xt (nth i pt_s2))
(setq pt_x pt_xt) (setq pt_x pt_xt)
(if (equal pt_xt (last pt_s2)) (if (equal pt_xt (last pt_s2))
(setq pt_xl (last pt_s2)) (setq pt_xl (last pt_s2))
(setq pt_xl (nth (1+ i) pt_s2)) (setq pt_xl (nth (1+ i) pt_s2))
)
(setq e 0) (setq e 0)
(setq q 0) ;while關鍵 (setq q 0) ;while关键
(while q (while q
(setq pt_y (car pt_s1)) (setq pt_y (car pt_s1))
(cond
((= pt_s1 nil) ;;判斷串列是否為空 ((= pt_s1 nil) ;;判断串列是否为空
(setq q nil) (setq q nil)
)
((equal pt_xt pt_y) ;;判斷座標是否相同 ((equal pt_xt pt_y) ;;判断座标是否相同
(setq q 0) (setq q 0)
(setq pt_s1 (cdr pt_s1)) (setq pt_s1 (cdr pt_s1))
)
((equal pt_xl pt_y) ((equal pt_xl pt_y)
(setq pt_s1 (cdr pt_s1)) (setq pt_s1 (cdr pt_s1))
(setq q nil) (setq q nil)
)
(t
(command "_line" pt_x pt_y "") (command "_line" pt_x pt_y "")
(setq pt_x pt_y) (setq pt_x pt_y)
(setq q 0) (setq q 0)
(setq pt_s1 (cdr pt_s1)) (setq pt_s1 (cdr pt_s1))
)
)
)
(setq i (1+ i)) (setq i (1+ i))
)
;;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(command "undo" "e") (command "undo" "e")
(prin1))
;;階層排序 ;;阶层排序
(defun sort-x-min-li (lst) (defun sort-x-min-li (lst)
(vl-sort lst '(lambda (xy) (< (car x)(car y) ) )) (vl-sort lst '(lambda (xy) (< (car x)(car y) ) ))
) ;x左->右 ) ;x左->右
(defun sort-x-max-li (lst) (defun sort-x-max-li (lst)
(vl-sort lst '(lambda (xy) (> (car x)(car y) ) )) (vl-sort lst '(lambda (xy) (> (car x)(car y) ) ))
) ;x右->左 ) ;x右->左
(defun sort-y-min-li (lst) (defun sort-y-min-li (lst)
(vl-sort lst '(lambda (xy) (< (cadr x)(cadr y) ) )) (vl-sort lst '(lambda (xy) (< (cadr x)(cadr y) ) ))
) ;y下->上 ) ;y下->上
(defun sort-y-max-li (lst) (defun sort-y-max-li (lst)
(vl-sort lst '(lambda (xy) (> (cadr x)(cadr y) ) )) (vl-sort lst '(lambda (xy) (> (cadr x)(cadr y) ) ))
) ;y上->下 ) ;y上->下
;;處理排序程式 ;;处理排序程式
(defun sort_type8_pt_list ( lst / ) (defun sort_type8_pt_list ( lst / )
(princ "\n 排序方式:") (princ "\n排序方式:")
(princ "\n <y方向>") (princ "\n <y方向>")
(princ "\n (a)左->右&上->下_(b)左->右&下->上_(c)右->左&上->下_(d)右->左&下->上") (princ "\n (a)左->右&上->下_(b)左->右&下->上_(c)右->左&上->下_(d)右->左&下->上")
(princ "\n <x方向>") (princ "\n <x方向>")
(princ "\n (e)上->下&左->右_(f)上->下&右->左_(g)下->上&左->右_(h)下->上&右->左") (princ "\n (e)上->下&左->右_(f)上->下&右->左_(g)下->上&左->右_(h)下->上&右->左")
(princ ".....<<")(princ "預設為a") (princ ">>:") (princ ".....<<")(princ "预设为a") (princ ">>:")
(initget "abcdefgh") (initget "abcdefgh")
(setq sf1 (getkword)) (setq sf1 (getkword))
(if (= sf1 nil)(setq sf1 a)) (if (= sf1 nil)(setq sf1 a))
(cond
((= sf1 "a")(progn ((= sf1 "a")(progn
(setq lstnew (sort-y-max-li lst)) (setq lstnew (sort-y-max-li lst))
(setq lstnew2 (sort-x-min-li lstnew)) (setq lstnew2 (sort-x-min-li lstnew))
)) ;;_(a)左->右&上->下 )) ;;_(a)左->右&上->下
((= sf1 "b")(progn ((= sf1 "b")(progn
(setq lstnew (sort-y-min-li lst)) (setq lstnew (sort-y-min-li lst))
(setq lstnew2 (sort-x-min-li lstnew)) (setq lstnew2 (sort-x-min-li lstnew))
)) ;;_(b)左->右&下->上 )) ;;_(b)左->右&下->上
((= sf1 "c")(progn ((= sf1 "c")(progn
(setq lstnew (sort-y-max-li lst)) (setq lstnew (sort-y-max-li lst))
(setq lstnew2 (sort-x-max-li lstnew)) (setq lstnew2 (sort-x-max-li lstnew))
)) ;;_(c)右->左&上->下 )) ;;_(c)右->左&上->下
((= sf1 "d")(progn ((= sf1 "d")(progn
(setq lstnew (sort-y-min-li lst)) (setq lstnew (sort-y-min-li lst))
(setq lstnew2 (sort-x-max-li lstnew)) (setq lstnew2 (sort-x-max-li lstnew))
)) ;;_(d)右->左&下->上 )) ;;_(d)右->左&下->上
((= sf1 "e")(progn ((= sf1 "e")(progn
(setq lstnew (sort-x-min-li lst)) (setq lstnew (sort-x-min-li lst))
(setq lstnew2 (sort-y-max-li lstnew)) (setq lstnew2 (sort-y-max-li lstnew))
)) ;;_(e)上->下&左->右 )) ;;_(e)上->下&左->右
((= sf1 "f")(progn ((= sf1 "f")(progn
(setq lstnew (sort-x-max-li lst)) (setq lstnew (sort-x-max-li lst))
(setq lstnew2 (sort-y-max-li lstnew)) (setq lstnew2 (sort-y-max-li lstnew))
)) ;;_(f)上->下&右->左 )) ;;_(f)上->下&右->左
((= sf1 "g")(progn ((= sf1 "g")(progn
(setq lstnew (sort-x-min-li lst)) (setq lstnew (sort-x-min-li lst))
(setq lstnew2 (sort-y-min-li lstnew)) (setq lstnew2 (sort-y-min-li lstnew))
)) ;;_(g)下->上&左->右 )) ;;_(g)下->上&左->右
((= sf1 "h")(progn ((= sf1 "h")(progn
(setq lstnew (sort-x-max-li lst)) (setq lstnew (sort-x-max-li lst))
(setq lstnew2 (sort-y-min-li lstnew)) (setq lstnew2 (sort-y-min-li lstnew))
)) ;;_(h)下->上&右->左 )) ;;_(h)下->上&右->左
)
lstnew2
)
(prompt "\n **<問題:沒有解決圖塊框線切割問題...>**") (prompt "\n **<问题:没有解决图块框线切割问题...>**")
(prompt "\n **<命令:tsk001>**") (prompt "\n **<命令:tsk001>**")

有人帮看下吗?
程序的修改
你的程序错误太多,lisp程序的( 和 )要对称的一个不能少.
我把你的程序改了一下现可加载了.
(defun c:tsk001 ()
(prompt "\n **<日期:2007-07-14.tsk001>**")
(prompt "\n **<用途:圖塊中心點連線>**") (prompt "\n **<用途:图块中心点连线>**")
(command "undo" "be")
;;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(setq s1 (ssget (list (cons 2 "12")) )) ;;
(setq i 0)
(setq pt_s1 nil)
(repeat (sslength s1)
(setq en (ssname s1 i)) (setq en (ssname s1 i))
(setq vla_en (vlax-ename->vla-object en)) (setq vla_en (vlax-ename->vla-object en))
(setq pt_s1 (append pt_s1 (list (vlax-get vla_en 'insertionpoint) ))) (setq pt_s1 (append pt_s1 (list (vlax-get vla_en 'insertionpoint) )))
(setq i (1+ i)) (setq i (1+ i))
)
;;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(print "選取連線基準圖塊...")
(setq s2 (ssget (list (cons 2 "12")) )) ;;
(setq i 0)
(setq pt_s2 nil)
(repeat (sslength s2)
(setq en (ssname s2 i)) (setq en (ssname s2 i))
(setq vla_en (vlax-ename->vla-object en)) (setq vla_en (vlax-ename->vla-object en))
(setq pt_s2 (append pt_s2 (list (vlax-get vla_en 'insertionpoint) ))) (setq pt_s2 (append pt_s2 (list (vlax-get vla_en 'insertionpoint) )))
(setq i (1+ i)) (setq i (1+ i))
)
(princ "\n 提示排序方式: e配a , c配b ...")
(setq pt_s1 (sort_type8_pt_list pt_s1)) ;
(setq pt_s2 (sort_type8_pt_list pt_s2)) ;
(setq e 0) ;(setq e 0)
(repeat (1- (length pt_s2))
(setq pt_s2-x (nth e pt_s2) pt_s2-y (nth (1+ e) pt_s2) pt_s2-y (nth (1+ e) pt_s2)) ;
(command "_line" pt_s2-x pt_s2-y "")
(setq e (1+ e))
)
(setq i 0)
(repeat (length pt_s2) ;repeat--
(setq pt_xt (nth i pt_s2))
(setq pt_x pt_xt)
(if (equal pt_xt (last pt_s2)) (setq pt_xl (last pt_s2)) (setq pt_xl (nth (1+ i) pt_s2)) )
(setq e 0)
(setq q 0) ;
(while q
(setq pt_y (car pt_s1)) (setq pt_y (car pt_s1))
(cond
((= pt_s1 nil) ;;
(setq q nil)
)
((equal pt_xt pt_y) ;;
(setq q 0)
(setq pt_s1 (cdr pt_s1))
)
((equal pt_xl pt_y) ((equal pt_xl pt_y)
(setq pt_s1 (cdr pt_s1)) (setq pt_s1 (cdr pt_s1))
(setq q nil)
)
(t
(command "_line" pt_x pt_y "")
(setq pt_x pt_y)
(setq q 0)
(setq pt_s1 (cdr pt_s1))
)
)
)
(setq i (1+ i))
) ;-q
;;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
(command "undo" "e")
(prin1)
) ;--repeat
) ;-defun tsk001
;;階層排序 ;;阶层排序
(defun sort-x-min-li (lst)
(vl-sort lst '(lambda (xy) (< (car x)(car y) ) ))
) ;x左->右 ) ;x左->右
(defun sort-x-max-li (lst)
(vl-sort lst '(lambda (xy) (> (car x)(car y) ) ))
) ;x右->左 ) ;x右->左
(defun sort-y-min-li (lst)
(vl-sort lst '(lambda (xy) (< (cadr x)(cadr y) ) ))
) ;y下->上 ) ;y下->上
(defun sort-y-max-li (lst)
(vl-sort lst '(lambda (xy) (> (cadr x)(cadr y) ) ))
) ;y上->下 ) ;y上->下
;;處理排序程式 ;;处理排序程式
(defun sort_type8_pt_list ( lst / )
(princ "\n 排序方式:")
(princ "\n <y方向>")
(princ "\n (a)左->右&上->下_(b)左->右&下->上_(c)右->左&上->下_(d)右->左&下->上")
(princ "\n <x方向>") (princ "\n <x方向>")
(princ "\n (e)上->下&左->右_(f)上->下&右->左_(g)下->上&左->右_(h)下->上&右->左")
(princ ".....<<")(princ "預設為a") (princ ">>:") (princ ".....<<")
(initget "abcdefgh")
(setq sf1 (getkword))
(if (= sf1 nil)(setq sf1 a))
(cond
((= sf1 "a")(progn
(setq lstnew (sort-y-max-li lst))
(setq lstnew2 (sort-x-min-li lstnew))
)) ;;_(a)左->右&上->下 )) ;;_(a)左->右&上->下
((= sf1 "b")(progn
(setq lstnew (sort-y-min-li lst))
(setq lstnew2 (sort-x-min-li lstnew))
)) ;;_(b)左->右&下->上 )) ;;_(b)左->右&下->上
((= sf1 "c")(progn ((= sf1 "c")(progn
(setq lstnew (sort-y-max-li lst))
(setq lstnew2 (sort-x-max-li lstnew))
)) ;;_(c)右->左&上->下 )) ;;_(c)右->左&上->下
((= sf1 "d")(progn ((= sf1 "d")(progn
(setq lstnew (sort-y-min-li lst))
(setq lstnew2 (sort-x-max-li lstnew))
)) ;;_(d)右->左&下->上 )) ;;_(d)右->左&下->上
((= sf1 "e")(progn
(setq lstnew (sort-x-min-li lst))
(setq lstnew2 (sort-y-max-li lstnew))
)) ;;_(e)上->下&左->右 )) ;;_(e)上->下&左->右
((= sf1 "f")
(progn
(setq lstnew (sort-x-max-li lst))
(setq lstnew2 (sort-y-max-li lstnew))
)) ;;_(f)上->下&右->左 )) ;;_(f)上->下&右->左
((= sf1 "g")(progn
(setq lstnew (sort-x-min-li lst))
(setq lstnew2 (sort-y-min-li lstnew))
)) ;;_(g)下->上&左->右 )) ;;_(g)下->上&左->右
((= sf1 "h")(progn
(setq lstnew (sort-x-max-li lst))
(setq lstnew2 (sort-y-min-li lstnew))
)) ;;_(h)下->上&右->左 )) ;;_(h)下->上&右->左
)
lstnew2
)
))))
(prompt "\n **<問題:沒有解決圖塊框線切割問題...>**") (prompt "\n **<问题:没有解决图块框线切割问题...>**")
(prompt "\n **命令:tsk001>**")
gbg

谢谢老顾,可不可以改成对pl线有效啊,非常感谢