跪求一LISP程序

hl2006 · 发表于 2010-7-19 19:28:00

有时主线出来接一些图元，有可能从线上拉出另外一根线去接另外一些图元。还有请教一下，为什么我把命中令放到2000版的CAD，系统是繁体的，为什么用不了

gufeng · 发表于 2010-7-20 11:02:00

理论上可以用，这没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)
)

(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)
  )

hl2006 · 发表于 2010-7-20 18:44:00

谢了啊，兄弟

hl2006 · 发表于 2010-7-21 19:25:00

我试了，放到2000的英文版也用不了，是啥原因哦，难道是版本问题吗

hl2006 · 发表于 2010-7-22 22:58:00

是不是有可能和其它的命中令有充突，

gufeng · 发表于 2010-7-23 09:54:00

有没有提示什么出错?

hl2006 · 发表于 2010-7-23 18:11:00

显示搜索不到文件，但我其它的LISP全都能用

gufeng · 发表于 2010-7-24 09:14:00

把文件 Function.fas 放到CAD2000的搜索路径

hl2006 · 发表于 2010-7-25 00:12:00

是在搜索路径

hl2006 · 发表于 2010-8-1 13:17:00

兄弟，有没有什么办法找出原因啊

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