跪求一LISP程序

hl2006 · 发表于 2010-7-1 21:00:00

在CAD中点一根线，而这根线所有连接的封闭图元，全部以填充变色的形式显视出来，点另一根就显视另一根所连接的图元，跪求了，谢谢大家啊，

hl2006 · 发表于 2010-7-11 09:19:00

有那位高手能帮我搞一个啊，小弟谢过了

gufeng · 发表于 2010-7-12 22:47:00

填充的时候要渐变色填充还是一种颜色填充?

hl2006 · 发表于 2010-7-14 19:40:00

一种颜色

hl2006 · 发表于 2010-7-14 19:42:00

但是点那根线的时候就就只有那根线所连接的图元变色，很清楚的分变出那根线上所接的东西

gufeng · 发表于 2010-7-15 11:39:00

1、文件 Function.fas 可于 http://e.ys168.com/?ls0201 上下载，主要是些通用函数打包部分来源于明经与网络
2、下载文件 Function.fas 后放于CAD搜索路径

(defun c:test (/ *ERROR* CP_ENAME CP_VLA HATCH_SS
H_COL H_LAYER I NEWENTLAST
OBJ OBJ_BOX OBJ_CP OBJ_PL
OBJ_TYPE OLDENTLAST OLDERROR TEST_ERROR
)
(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 "")
)
)
(setq h_col 3) ;_定义填充的颜色 1-红 2-黄 3-绿 4-青 5-蓝 6-品红 7-白
(setq h_layer "填充色20100715") ;_定义填充的图层
(vl-load-com)
(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 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))
(setq obj_cp (ssget "f" obj_pl '((0 . "*POLYLINE"))))
(if obj_cp
(progn
(if (ssmemb obj obj_cp)
(setq obj_cp (ssdel obj obj_cp))
)
(if (> (sslength obj_cp) 0)
(progn
(setq i -1)
(setq hatch_ss (ssadd))
(repeat (sslength obj_cp)
(setq
cp_vla (vlax-ename->vla-object
(setq
cp_ename (ssname obj_cp
(setq i (1+ i))
)
)
)
)
(if (vlax-curve-isClosed cp_vla)
(setq hatch_ss (ssadd cp_ename hatch_ss))
)
)
(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
"")
)
)
)
)
)
)
)
)
(command "_zoom" "_p")
)
)
)
(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      NEWENTLAST
   OBJ      OBJ_BOX  OBJ_CP      OBJ_PL
   OBJ_TYPE    OLDENTLAST  OLDERROR    TEST_ERROR
  )
  (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 "")
      )
  )
  (setq h_col 3) ;_定义填充的颜色 1-红 2-黄 3-绿 4-青 5-蓝 6-品红 7-白
  (setq h_layer "填充色20100715") ;_定义填充的图层
  (vl-load-com)
  (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 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))
  (setq obj_cp (ssget "f" obj_pl '((0 . "*POLYLINE"))))
  (if obj_cp
    (progn
      (if (ssmemb obj obj_cp)
 (setq obj_cp (ssdel obj obj_cp))
      )
      (if (> (sslength obj_cp) 0)
 (progn
   (setq i -1)
   (setq hatch_ss (ssadd))
   (repeat (sslength obj_cp)
     (setq
       cp_vla (vlax-ename->vla-object
         (setq
    cp_ename (ssname obj_cp
       (setq i (1+ i))
      )
         )
       )
     )
     (if (vlax-curve-isClosed cp_vla)
       (setq hatch_ss (ssadd cp_ename hatch_ss))
     )
   )
   (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
      "")
  )
       )
     )
   )
 )
      )
    )
  )
  (command "_zoom" "_p")
)
)
)
(progn
(alert "\n搜索目录没有找到文件 Function.fas")
)
)
  (setq *error* olderror)
  (del_old_hatch h_layer)
  (princ)
)

hl2006 · 发表于 2010-7-16 22:08:00

谢谢兄弟啊。在下感激不尽

hl2006 · 发表于 2010-7-16 22:35:00

兄弟，怎么用不了啊

hl2006 · 发表于 2010-7-16 22:36:00

拜托再次指导一下

gufeng · 发表于 2010-7-16 23:39:00

怎么个用不了?

1、文件 Function.fas 可于 http://e.ys168.com/?ls0201 上下载，主要是些通用函数打包部分来源于明经与网络

2、下载文件 Function.fas 后放于CAD搜索路径

Function.fas 文件放在搜索路径了?

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