<p>有时主线出来接一些图元，有可能从线上拉出另外一根线去接另外一些图元。还有请教一下，为什么我把命中令放到2000版的CAD，系统是繁体的，为什么用不了</p>
理论上可以用 ，这没2000繁体版测试不了
(defun c:test (/ *ERROR* CP_ENAME CP_VLA HATCH_SS H_COL
H_LAYER I II OBJ OBJ_8
OBJ_CP OBJ_SEC OBJ_SEC_NAME OBJ_TYPE
OLDERROR TEST_ERROR
)
(vl-load-com)
(setq h_col 3) ;_定义填充的颜色 1-红 2-黄 3-绿 4-青 5-蓝 6-品红 7-白
(setq h_layer "填充色20100715") ;_定义填充的图层
;_错误处理或按Esc键操作
(defun test_error (test_error_msg)
(setq *error* olderror)
(del_old_hatch h_layer)
)
;_删除原填充
(defun del_old_hatch (layer / OLD_HAT_OBJ)
(setq old_hat_obj
(ssget "x" (list (cons 0 "Hatch") (cons 8 layer)))
)
(if old_hat_obj
(command "_ERASE" old_hat_obj "")
)
)
;_返回与 obj 图元 相交闭合的多段线选择集
(defun s_hatch_obj (obj / OBJ_8 OBJ_BOX OBJ_CP OBJ_PL)
(setq obj_pl (PL_plist_xy_list obj)) ;_坐标表
(setq obj_pl (xyp1-delsame obj_pl)) ;_删除相同的项
(setq obj_box (getbox obj)) ;_多段线最大包围框
(command "_zoom" (car obj_box) (last obj_box));_Zoom 方便 栏选 选择对象
(setq obj_cp (ssget "f" obj_pl '((0 . "*POLYLINE"))))
(command "_zoom" "_p")
(if obj_cp
(progn
(if (ssmemb obj obj_cp)
(setq obj_cp (ssdel obj obj_cp));_去掉自身的图元名
)
(if (= (sslength obj_cp) 0)
(setq obj_cp nil)
)
)
)
obj_cp
)
;_填充
(defun Hatch_obj_ss (HATCH_SS H_COL H_LAYER / NEWENTLAST OLDENTLAST)
(progn
(if (> (sslength hatch_ss) 0)
(progn
(setq oldentlast (entlast))
(command "_hatch" "SOLID" hatch_ss "")
(setq newentlast (entlast))
(if (equal oldentlast newentlast)
(progn
(alert "\n特殊原因无法填充")
)
(progn
(command "_change" newentlast "" "_p" "_color" h_col "")
(command "_change" newentlast "" "_p" "_layer" h_layer "")
)
)
)
)
)
)
(setq olderror *error*
*error*test_error
)
(if (findfile "Function.fas")
(progn
(load "Function.fas")
(while (and (setq obj (car (entsel "\n选择多段线")))
(or (=
(setq obj_type (cdr (assoc 0 (entget obj))))
"POLYLINE"
)
(= obj_type "LWPOLYLINE")
)
)
(progn
(if (= nil (tblsearch "layer" h_layer))
(command "-layer" "new" h_layer "")
)
(del_old_hatch h_layer)
(setq hatch_ss (ssadd))
(setq obj_Sec (ssadd))
(setq obj_cp (s_hatch_obj obj))
(if obj_cp
(progn
(setq i -1)
(repeat (sslength obj_cp)
(setq cp_ename (ssname obj_cp (setq i (1+ i))))
(setq cp_vla (vlax-ename->vla-object cp_ename))
(if (vlax-curve-isClosed cp_vla)
(setq hatch_ss (ssadd cp_ename hatch_ss))
(progn
(setq obj_8 (cdr (assoc 8 (entget obj))))
(if (= (cdr (assoc 8 (entget cp_ename))) obj_8)
(setq obj_Sec (ssadd cp_ename obj_Sec))
)
)
)
)
(if (> (sslength obj_Sec) 0)
(progn
(setq ii -1)
(repeat (sslength obj_Sec)
(setq obj_Sec_name (ssname obj_Sec (setq ii (1+ ii))))
(setq obj_cp (s_hatch_obj obj_Sec_name))
(if obj_cp
(progn
(setq i -1)
(repeat (sslength obj_cp)
(setq cp_ename (ssname obj_cp (setq i (1+ i))))
(setq cp_vla (vlax-ename->vla-object cp_ename))
(if (vlax-curve-isClosed cp_vla)
(setq hatch_ss (ssadd cp_ename hatch_ss))
)
)
)
)
)
)
)
(Hatch_obj_ss HATCH_SS H_COL H_LAYER)
)
)
)
)
)
(progn
(alert "\n搜索目录没有找到文件 Function.fas")
)
)
(setq *error* olderror)
(del_old_hatch h_layer)
(princ)
)
谢了啊，兄弟
我试了，放到2000的英文版也用不了，是啥原因哦，难道是版本问题吗
<p>是不是有可能和其它的命中令有充突，</p>
<p>有没有提示什么出错?</p>
<p>显示搜索不到文件，但我其它的LISP全都能用</p>
把文件 <font face="Verdana">Function.fas</font> 放到CAD2000的搜索路径
是在搜索路径
<p>兄弟，有没有什么办法找出原因啊</p>