[原创]：Eachy 工具集 Lisp源码详解

eachy · 发表于 2009-1-4 15:43:55

两个使用 vla 部分经常要用到的函数

;;清除前一选择集
(defun ybvl-Clearcset (/ cset)
(if (not (vl-catch-all-error-p
(setq cset
(vl-catch-all-apply
'vla-item
(list
(vlax-get-property
*AcDocumnet*
'selectionsets
)
"CURRENT"
)
)
)
)
)
(vla-delete cset)
)
(princ)
)
;|
功能由activex变体返回lisp值
语法 (lisp-value v)
参数一个activex变体或安全数组
返回值 lisp值
样例 (lisp-value myvariant)
说明
该函数将递归深入一个安全数组并转换所有的值，包括嵌套的安全数组，将其转换为lisp值。
|;
(defun lisp-value (v)
(cond
((= (type v) 'variant)
(lisp-value (variant-value v))
)
((= (type v) 'safearray)
(mapcar 'lisp-value (safearray-value v))
)
(t v)
)
)

;;清除前一选择集 
(defun ybvl-Clearcset (/ cset) 
  (if (not (vl-catch-all-error-p 
             (setq cset 
                    (vl-catch-all-apply 
                      'vla-item 
                      (list 
                        (vlax-get-property 
                          *AcDocumnet* 
                          'selectionsets 
                        ) 
                        "CURRENT" 
                      ) 
                    ) 
             ) 
           ) 
      ) 
    (vla-delete cset) 
  ) 
  (princ) 
) 
 ;| 
功  能  由activex变体返回lisp值 
语  法  (lisp-value v) 
参  数  一个activex变体或安全数组 
返回值  lisp值 
样  例  (lisp-value myvariant) 
说  明 
该函数将递归深入一个安全数组并转换所有的值，包括嵌套的安全数组，将其转换为lisp值。 
|; 
(defun lisp-value (v) 
  (cond 
    ((= (type v) 'variant) 
     (lisp-value (variant-value v)) 
    ) 
    ((= (type v) 'safearray) 
     (mapcar 'lisp-value (safearray-value v)) 
    ) 
    (t v) 
  ) 
)

eachy · 发表于 2009-1-4 15:50:29

这是 eatools.mnl ，带有一定的“免疫”能力

(vl-load-com)
(defun ai_ffile (app)
(or (findfile (strcat app ".lsp"))
(findfile (strcat app ".exp"))
(findfile (strcat app ".exe"))
(findfile (strcat app ".arx"))
(findfile (strcat app ".fas"))
(findfile (strcat app ".vlx"))
(findfile app)
)
)
(defun ai_nofile (filename)
(princ
(strcat "\n在支持路径中未找到 "
filename
"(.lsp/.exe/.arx/.fas/.vlx) 文件."
)
)
(princ "\n检查你的 Support 路径并再次运行.")
(princ)
)
(defun ybl-str-parse (str delimiter / post strlst)
(if str
(progn
(setq strlst '())
(while (vl-string-search delimiter str)
(setq post (vl-string-search delimiter str))
(setq strlst (append strlst (list (substr str 1 post))))
(setq str (substr str (+ post 2)))
)
(vl-remove "" (append strlst (list str)))
)
)
)
;;;AddSupportPath
;;;添加文件夹到AutoCAD支持搜索路径中的指定位置
;;;参数
;;;文件夹路径及插入的位置(0时插入前端)
;;;示例
;;;(addSupportPath "c:\\myFolder" 2)
;;;注意
;;;位置参数为空时将文件夹添加到路径最后。位置参数为0时将文件夹添加到路径最前端。
(defun addSupportPath (dir pos / tmp c)
(setq tmp ""
c -1
)
(if (not pos)
(setq tmp (strcat (getenv "ACAD") ";" dir))
(mapcar '(lambda (x)
(setq tmp (if (= (setq c (1+ c)) pos)
(strcat tmp ";" dir ";" x)
(strcat tmp ";" x)
)
)
)
(ea:string_parse (getenv "ACAD") ";")
)
)
(setenv "ACAD" tmp)
(princ)
)
;;适合2002-2006的由加载的菜单自动添加菜单所在文件夹道支持路径的数
;; eachy [[url]www.xdcad.net[/url]] 2005.5.24
(defun Ea:AddSupport (mnu / path acadpath)
(vlax-map-collection
(vla-get-menugroups (vlax-get-acad-object))
'(lambda (x /)
(if (= (strcase (vla-get-name x)) (strcase mnu))
(setq path
(strcase
(vl-filename-directory (vla-get-menufilename x))
)
)
)
)
)
(if path
(progn
(setq acadpath (strcase (getenv "ACAD")))
(if (not (wcmatch (strcat path ";") acadpath))
(addSupportPath path nil)
)
)
)
(princ)
)
(if (not (menugroup "eatools"))
(vl-cmdf ".menuload" "eatools.mnu")
)
(menucmd "p25=+eatools.pop1")
(Ea:Addsupport "eatools")
(if (not (member 'EATOOLS (vl-list-loaded-vlx)))
(load "eatools.vlx")
)
(if (= (getenv "ScreenMenu") "1")
(ea:resscrmnu)
)
(defun ybl-readfile (fn / f l ll)
(setq f (open (findfile fn) "r"))
(while (setq l (read-line f))
(setq ll (cons l ll))
)
(close f)
ll
)
(setvar "cmdecho" 0)
(if (findfile "acad.lsp")
(progn
(setq stl (mapcar
'(lambda (x) (vl-string-trim "\\"\t()" x))
(mapcar 'strcase (ybl-readfile (findfile "acad.lsp")))
)
)
(if (or (vl-position "ACADAPP" stl)
(vl-position "ACADAPP.LSP" stl)
(vl-position "WRITEAPP" stl)
)
(progn
(vl-file-delete (findfile "acad.lsp"))
(if (findfile "acadapp.lsp")
(vl-file-delete app)
)
(alert
" 您的CAD可能被ACAD.LSP病毒感染，\n\n失效命令已经恢复，退出CAD后请杀毒!"
)
)
)
(if (= (type c:explode) 'USUBR)
(progn
(setq c:explode nil)
(command ".redefine" "explode" ".explode")
)
)
(if (= (type c:burst) 'USUBR)
(progn
(setq c:burst nil)
(command ".redefine" "burst" ".burst")
)
)
(if (= (type c:xref) 'USUBR)
(progn
(setq c:xref nil)
(command ".redefine" "xref" ".xref")
)
)
(if (= (type c:xbind) 'USUBR)
(progn
(setq c:xbind nil)
(command ".redefine" "xbind" ".xbind")
)
)
(setq fl nil
app nil
stl nil
)
)
)
(vlr-remove-all)
(princ)

(vl-load-com) 
(defun ai_ffile        (app) 
  (or (findfile (strcat app ".lsp")) 
      (findfile (strcat app ".exp")) 
      (findfile (strcat app ".exe")) 
      (findfile (strcat app ".arx")) 
      (findfile (strcat app ".fas")) 
      (findfile (strcat app ".vlx")) 
      (findfile app) 
  ) 
) 
(defun ai_nofile (filename) 
  (princ 
    (strcat "\n在支持路径中未找到 " 
            filename 
            "(.lsp/.exe/.arx/.fas/.vlx) 文件." 
    ) 
  ) 
  (princ "\n检查你的 Support 路径并再次运行.") 
  (princ) 
) 
(defun ybl-str-parse (str delimiter / post strlst) 
  (if str 
    (progn 
      (setq strlst '()) 
      (while (vl-string-search delimiter str) 
        (setq post (vl-string-search delimiter str)) 
        (setq strlst (append strlst (list (substr str 1 post)))) 
        (setq str (substr str (+ post 2))) 
      ) 
      (vl-remove "" (append strlst (list str))) 
    ) 
  ) 
) 
;;;AddSupportPath 
;;;添加文件夹到AutoCAD支持搜索路径中的指定位置 
;;;参数 
;;;文件夹路径及插入的位置(0时插入前端) 
;;;示例 
;;;(addSupportPath "c:\\myFolder" 2) 
;;;注意 
;;;位置参数为空时将文件夹添加到路径最后。位置参数为0时将文件夹添加到路径最前端。 
(defun addSupportPath (dir pos / tmp c) 
  (setq        tmp "" 
        c   -1 
  ) 
  (if (not pos) 
    (setq tmp (strcat (getenv "ACAD") ";" dir)) 
    (mapcar '(lambda (x) 
               (setq tmp (if (= (setq c (1+ c)) pos) 
                           (strcat tmp ";" dir ";" x) 
                           (strcat tmp ";" x) 
                         ) 
               ) 
             ) 
            (ea:string_parse (getenv "ACAD") ";") 
    ) 
  ) 
  (setenv "ACAD" tmp) 
  (princ) 
) 
;;适合2002-2006的由加载的菜单自动添加菜单所在文件夹道支持路径的数 
;;                           eachy [[url]www.xdcad.net[/url]] 2005.5.24 
(defun Ea:AddSupport (mnu / path acadpath) 
  (vlax-map-collection 
    (vla-get-menugroups (vlax-get-acad-object)) 
    '(lambda (x /) 
       (if (= (strcase (vla-get-name x)) (strcase mnu)) 
         (setq path 
                (strcase 
                  (vl-filename-directory (vla-get-menufilename x)) 
                ) 
         ) 
       ) 
     ) 
  ) 
  (if path 
    (progn 
      (setq acadpath (strcase (getenv "ACAD"))) 
      (if (not (wcmatch (strcat path ";") acadpath)) 
        (addSupportPath path nil) 
      ) 
    ) 
  ) 
  (princ) 
) 
 
(if (not (menugroup "eatools")) 
  (vl-cmdf ".menuload" "eatools.mnu") 
) 
(menucmd "p25=+eatools.pop1") 
(Ea:Addsupport "eatools") 
(if (not (member 'EATOOLS (vl-list-loaded-vlx))) 
  (load "eatools.vlx") 
) 
(if (= (getenv "ScreenMenu") "1") 
  (ea:resscrmnu) 
) 
 
(defun ybl-readfile (fn / f l ll) 
  (setq f (open (findfile fn) "r")) 
  (while (setq l (read-line f)) 
    (setq ll (cons l  ll)) 
  ) 
  (close f) 
  ll 
) 
(setvar "cmdecho" 0) 
(if (findfile "acad.lsp") 
  (progn 
    (setq stl (mapcar 
                '(lambda (x) (vl-string-trim "\\"\t()" x)) 
                (mapcar 'strcase (ybl-readfile (findfile "acad.lsp"))) 
              ) 
    ) 
    (if        (or (vl-position "ACADAPP" stl) 
            (vl-position "ACADAPP.LSP" stl) 
            (vl-position "WRITEAPP" stl) 
        ) 
      (progn 
        (vl-file-delete (findfile "acad.lsp")) 
        (if (findfile "acadapp.lsp") 
          (vl-file-delete app) 
        ) 
        (alert 
          "  您的CAD可能被ACAD.LSP病毒感染，\n\n失效命令已经恢复，退出CAD后请杀毒!" 
        ) 
      ) 
    ) 
    (if        (= (type c:explode) 'USUBR) 
      (progn 
        (setq c:explode nil) 
        (command ".redefine" "explode" ".explode") 
      ) 
    ) 
    (if        (= (type c:burst) 'USUBR) 
      (progn 
        (setq c:burst nil) 
        (command ".redefine" "burst" ".burst") 
      ) 
    ) 
    (if        (= (type c:xref) 'USUBR) 
      (progn 
        (setq c:xref nil) 
        (command ".redefine" "xref" ".xref") 
      ) 
    ) 
    (if        (= (type c:xbind) 'USUBR) 
      (progn 
        (setq c:xbind nil) 
        (command ".redefine" "xbind" ".xbind") 
      ) 
    ) 
    (setq fl  nil 
          app nil 
          stl nil 
    ) 
    
  ) 
) 
(vlr-remove-all) 
(princ)

158466939 · 发表于 2009-1-4 16:11:47

顶。。。。。。。。。。
小弟在此代表大家感谢eachy的无私奉献
也表达下大家的心声，能否每天来点，大家等的好心急。。。。。。

eachy · 发表于 2009-1-4 16:29:03

再贴一个 Lib_blk.lsp ，这个文件的功能是对工具集中用到的图块进行制作，这样就不必附带一堆 dwg 文件

;;室外标高 3 三角 1 十字 2 圆点
(defun ea:MkSWBG (tf / pln blkdef oldlay oldcol)
(setq oldlay (getvar "clayer")
oldcol (getvar "cecolor")
)
(setvar "clayer" "0")
(setvar "cecolor" "bylayer")
(setq blkdef (cond ((= tf 3) (ybvl-addblk "EA_SBG3"))
((= tf 1) (ybvl-addblk "EA_SBG1"))
((= tf 2) (ybvl-addblk "EA_SBG2"))
)
)
(cond
((= tf 3)
(ybvl-addsolid
blkdef
(list '(-1.3212 0.9909 0.)
'(1.3212 0.9909 0.)
'(0. 0. 0.)
'(0. 0. 0.)
)
)
)
((= tf 1)
(setq pln (ybvl-addpline
blkdef
'(0. -1.25 0. 1.25)
)
)
(vla-setwidth pln 0 0.35 0.35)
(setq pln (ybvl-addpline
blkdef
'(-1.25 0. 1.25 0.)
)
)
(vla-setwidth pln 0 0.35 0.35)
)
((= tf 2)
(setq pln (ybvl-addpline
blkdef
'(-0.25 0. 0.25 0.)
)
)
(vla-setBulge pln 0 1.0)
(vla-put-closed pln :vlax-true)
(vla-setbulge pln 1 1.0)
(vla-setwidth pln 0 0.5 0.5)
(vla-setwidth pln 1 0.5 0.5)
)
)
(ybl-addatt blkdef
(cond ((= tf 1) '(2.25 0. 0.))
((= tf 3) '(0. 2.23 0.))
((= tf 2) '(1.5 0. 0.))
)
1
"标高"
""
""
(apply '* (ea:init))
(if (= tf 3)
"C"
"ML"
)
0.75
nil
)
(setvar "clayer" oldlay)
(setvar "cecolor" oldcol)
)
;;雨水井
(defun Ea:MkYSJ (/ blkdef oldlay oldcol)
(setq oldlay (getvar "clayer")
oldcol (getvar "cecolor")
)
(setvar "clayer" "0")
(setvar "cecolor" "bylayer")
(setq blkdef (ybvl-addblk "EA_YSJ"))
(ybvl-addsolid
blkdef
'((-2.0 2.0 0.) (0. 2.0 0.) (-2.5 0. 0.) (0. 0. 0.))
)
(ybvl-addpline
blkdef
'(0. 0. 2.5 0. 2.0 2.0 0. 2.0)
)
(setvar "clayer" oldlay)
(setvar "cecolor" oldcol)
)
;;建筑编号
(defun Ea:MkBH (/ blkdef pln oldlay oldcol)
(setq oldlay (getvar "clayer")
oldcol (getvar "cecolor")
)
(setvar "clayer" "0")
(setvar "cecolor" "bylayer")
(setq blkdef (ybvl-addblk "EA_JZBH"))
(setq pln (ybvl-addpline
blkdef
'(-4. 0. 4. 0.)
)
)
(vla-setBulge pln 0 1.0)
(vla-put-closed pln :vlax-true)
(vla-setbulge pln 1 1.0)
(vla-setwidth pln 0 0.35 0.35)
(vla-setwidth pln 1 0.35 0.35)
(ybvl-addatt blkdef '(0. 0. 0.) 1 "BH" "" "BH" 3. "MC" 0.8 0.)
(setvar "clayer" oldlay)
(setvar "cecolor" oldcol)
)

;;室外标高 3 三角 1 十字 2 圆点 
(defun ea:MkSWBG (tf / pln blkdef oldlay oldcol) 
  (setq        oldlay (getvar "clayer") 
        oldcol (getvar "cecolor") 
  ) 
  (setvar "clayer" "0") 
  (setvar "cecolor" "bylayer") 
  (setq        blkdef (cond ((= tf 3) (ybvl-addblk "EA_SBG3")) 
                     ((= tf 1) (ybvl-addblk "EA_SBG1")) 
                     ((= tf 2) (ybvl-addblk "EA_SBG2")) 
               ) 
  ) 
  (cond 
    ((= tf 3) 
     (ybvl-addsolid 
       blkdef 
       (list '(-1.3212 0.9909 0.) 
             '(1.3212 0.9909 0.) 
             '(0. 0. 0.) 
             '(0. 0. 0.) 
       ) 
     ) 
    ) 
    ((= tf 1) 
     (setq pln (ybvl-addpline 
                 blkdef 
                 '(0. -1.25 0. 1.25) 
               ) 
     ) 
     (vla-setwidth pln 0 0.35 0.35) 
     (setq pln (ybvl-addpline 
                 blkdef 
                 '(-1.25 0. 1.25 0.) 
               ) 
     ) 
     (vla-setwidth pln 0 0.35 0.35) 
    ) 
    ((= tf 2) 
     (setq pln (ybvl-addpline 
                 blkdef 
                 '(-0.25 0. 0.25 0.) 
               ) 
     ) 
     (vla-setBulge pln 0 1.0) 
     (vla-put-closed pln :vlax-true) 
     (vla-setbulge pln 1 1.0) 
     (vla-setwidth pln 0 0.5 0.5) 
     (vla-setwidth pln 1 0.5 0.5) 
    ) 
  ) 
  (ybl-addatt blkdef 
             (cond ((= tf 1) '(2.25 0. 0.)) 
                   ((= tf 3) '(0. 2.23 0.)) 
                   ((= tf 2) '(1.5 0. 0.)) 
             ) 
             1 
             "标高" 
             "" 
             "" 
             (apply '* (ea:init)) 
             (if (= tf 3) 
               "C" 
               "ML" 
             ) 
             0.75 
             nil 
  ) 
  (setvar "clayer" oldlay) 
  (setvar "cecolor" oldcol) 
) 
;;雨水井 
(defun Ea:MkYSJ        (/ blkdef oldlay oldcol) 
  (setq        oldlay (getvar "clayer") 
        oldcol (getvar "cecolor") 
  ) 
  (setvar "clayer" "0") 
  (setvar "cecolor" "bylayer") 
  (setq blkdef (ybvl-addblk "EA_YSJ")) 
  (ybvl-addsolid 
    blkdef 
    '((-2.0 2.0 0.) (0. 2.0 0.) (-2.5 0. 0.) (0. 0. 0.)) 
  ) 
  (ybvl-addpline 
    blkdef 
    '(0. 0. 2.5 0. 2.0 2.0 0. 2.0) 
  ) 
  (setvar "clayer" oldlay) 
  (setvar "cecolor" oldcol) 
) 
;;建筑编号 
(defun Ea:MkBH (/ blkdef pln oldlay oldcol) 
  (setq        oldlay (getvar "clayer") 
        oldcol (getvar "cecolor") 
  ) 
  (setvar "clayer" "0") 
  (setvar "cecolor" "bylayer") 
  (setq blkdef (ybvl-addblk "EA_JZBH")) 
  (setq        pln (ybvl-addpline 
              blkdef 
              '(-4. 0. 4. 0.) 
            ) 
  ) 
  (vla-setBulge pln 0 1.0) 
  (vla-put-closed pln :vlax-true) 
  (vla-setbulge pln 1 1.0) 
  (vla-setwidth pln 0 0.35 0.35) 
  (vla-setwidth pln 1 0.35 0.35) 
  (ybvl-addatt blkdef '(0. 0. 0.) 1 "BH" "" "BH" 3. "MC" 0.8 0.) 
  (setvar "clayer" oldlay) 
  (setvar "cecolor" oldcol) 
)

eachy · 发表于 2009-1-4 16:48:32

这个是组操作命令， Group.lsp ，Eatools 工具集基本是通用编辑，所以命名基本按 Autocad Object 类型组织

通用函数

(defun ybl-obj-reactor (e / elst lst etlst)
(setq elst (entget e))
(if (and (assoc 102 elst)
(= (cdr (assoc 102 elst)) "{ACAD_REACTORS")
)
(progn
(setq lst (cdr (member '(102 . "{ACAD_REACTORS") elst)))
(while (= (caar lst) 330)
(setq etlst (cons (cdar lst) etlst))
(setq lst (cdr lst))
)
)
)
etlst
)
(defun ActiveSSet ()
(vla-get-activeselectionset *AcDocument*)
)

程序部分 Group.lsp

(defun ybl-ent-grpname (lst / g)
(if lst
(foreach item (mapcar 'vlax-ename->vla-object lst)
(if (= (vla-get-objectname item) "AcDbGroup")
(setq g (cons (vla-get-name item) g)
)
)
)
)
g
)
(defun ybvl-addgroup (groupname)
(if (not
(vl-catch-all-error-p
(setq tf (vl-catch-all-apply
'vla-item
(list (vla-get-groups *AcDocument*) groupname)
)
)
)
)
tf
(vla-add
(vla-get-groups *AcDocument*)
groupname
)
)
)
(defun ea:group->pickset (groupname / ss)
(setq ss (ssadd))
(setq group (vla-item (vla-get-groups *AcDocument*) groupname))
(if (/= (vla-get-count group) 0)
(vlax-for i (vla-item (vla-get-groups *AcDocument*) groupname)
(ssadd (vlax-vla-object->ename i) ss)
)
)
(cadr (sssetfirst nil ss))
(ssgetfirst)
;(ssget "p")
)
;|
组操作，透明命令，全局组选开关
|;
(defun c:EA:GroupOnOf ()
(if (= (getvar "pickstyle") 0)
(progn
(setvar "pickstyle" 1)
(prompt "\n组功能启用.")
)
(progn
(setvar "pickstyle" 0)
(prompt "\n组功能禁用.")
)
)
(princ)
)
;|
功能：单组选开关，可以在系统变量PICKSTYLE＝1的情况下，使单独的组变换是否整体和分散。
|;
(defun c:Ea:GroupSOnOf (/ e group)
(if (and
(setq e (car (entsel "\n请拾取一个组中的实体<退出>: ")))
(setq group (ybl-obj-reactor e))
(ybl-ent-grpname group)
)
(progn
(if (= 1 (cdr (assoc 71 (entget (car group)))))
(progn
(entmod (subst '(71 . 0)
(assoc 71 (entget (car group)))
(entget (car group))
)
)
(prompt "\n该实体属于的组可以单选。")
)
(progn
(entmod (subst '(71 . 1)
(assoc 71 (entget (car group)))
(entget (car group))
)
)
(prompt "\n该实体属于的组已经作为整体。")
)
)
)
)
(princ)
)
(defun ybvl-MkGroup (ss gname / group lst group_obj)
(setq group (ybvl-addgroup gname))
(if (/= (vla-get-count group) 0)
(progn
(vlax-for i group
(setq group_obj (cons i group_obj))
)
(setq group_obj (reverse group_obj))
)
)
(vlax-for ent (activesset)
(if group_obj
(if (not (member ent group_obj))
(setq lst (cons ent lst))
)
(setq lst (cons ent lst))
)
)
(if lst
(progn
(vla-AppendItems
group
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbObject
(cons 0 (1- (length lst)))
)
lst
)
)
(vla-get-name group)
)
)
)
(defun c:Ea:GroupMake (/ ss gname gn)
(ybvl-clearcset)
(prompt "\n请选取要组成组的实体<退出>:")
(if (setq ss (ssget))
(progn
(setq gName (getstring "\n请输入组名<制匿名组>:"))
(if (not (setq gn (ybvl-MkGroup
ss
(if (or (= gname "")
(= gname "*")
)
"*"
gname
)
)
)
)
(prompt (strcat "\n已经把选择的实体制成组，组名是 "
gn
"."
)
)
(princ (strcat "\n所选实体已经属于 " gName " 组."))
)
)
)
(princ)
)
;|
功能：去除组定义
|;
(defun c:Ea:GroupDel (/ e gName group)
(if (and
(setq e (car (entsel "\n请拾取一个组中的实体<退出>: ")))
(setq group (ybl-obj-reactor e))
(ybl-ent-grpname group)
)
(progn
(setq gName (vla-get-name (vlax-ename->vla-object (car group))))
(entdel (car group))
(prompt
(strcat "\n组 "
gName
" 已经从数据库中删除。"
)
)
)
)
(princ)
)
;|
功能：不用分解直接删除组内实体
|;
(defun c:Ea:GroupDelEnt (/ e)
(while (setq e (car (entsel "\n请拾取一个组中要删除的实体<退出>: ")))
(entdel e)
)
(princ)
)
;|
功能：往组内添加实体
|;
(defun c:Ea:GroupAddEnt (/ e gNa ss group group_obj lst glst)
(ybvl-clearcset)
(if (and
(setq e (car (entsel "\n请拾取一个组中的实体确定组<退出>: ")))
(setq group (ybl-obj-reactor e))
(setq gNa (ybl-ent-grpname group))
(progn
(prompt
(strcat "\n请选取要添加到组 " (car gNa) " 中的实体<退出>:")
)
(setq ss (ssget))
)
)
(progn
(setq glst (reverse (entget (car group))))
(vlax-for i (activesset)
(setq
glst (append (list (cons 340 (vlax-vla-object->ename i)))
glst
)
)
)
(entmod (reverse glst))
)
)
(princ)
)
;|
功能：不用分解直接移出组内实体
|;
(defun c:Ea:GroupRemoveEnt (/ e gName group)
(if (and
(setq e (car (entsel "\n请拾取一个组中要移出的实体<退出>: ")))
(setq group (ybl-obj-reactor e))
)
(progn
(setq gName (ybl-ent-grpname group))
(entmod (vl-remove (cons 340 e) (entget (car group))))
(prompt (strcat "\n实体已经从组 " (car gName) " 移出。"))
)
)
(princ)
)
;|
功能：合并两个组
说明：合并后，第二个组定义将从数据库删除
|;
(defun c:Ea:GroupMerge (/ e1 e2 gNa1 gNa2 nNums ss group1 group2 glst)
(if (and (setq e1 (car (entsel "\n拾取第一个组内的一个实体<退出>:")))
(setq group1 (ybl-obj-reactor e1))
(setq gNa1 (ybl-ent-grpname group1))
(if gNa1
(progn
(vla-highlight
(vlax-ename->vla-object (car group1))
:vlax-false
)
t
)
)
(setq e2 (car (entsel "\n拾取第二个组内的一个实体<退出>:")))
(setq group2 (ybl-obj-reactor e2))
(setq gNa2 (ybl-ent-grpname group2))
(if gNa2
(progn
(vla-highlight
(vlax-ename->vla-object (car group2))
:vlax-false
)
t
)
)
)
(progn
(setq
nNums (vla-get-count (vlax-ename->vla-object (car group2)))
)
(if (> nNums 0)
(progn
(setq glst (append (vl-member-if-not
'(lambda (x) (/= (car x) 340))
(entget (car group2))
)
(reverse (entget (car group1)))
)
)
(entmod (reverse glst))
(entdel (car group2))
(vla-highlight
(vlax-ename->vla-object (car group1))
:vlax-true
)
(prompt (strcat "\n组 "
(car gNa2)
" 已经合并到组 "
(car gNa1)
" 中。"
)
)
)
)
)
)
(princ)
)
(defun ea:DelGrp (mod / n s seconds)
(setq n 0
s (getvar "date")
seconds (* 86400.0 (- s (fix s)))
)
(vla-startundomark *AcDocument*)
(if mod
(vlax-map-collection
(vlax-get-property *AcDocument* 'groups)
'(lambda (x)
(if (wcmatch (vlax-get-property x 'name) "`**")
(progn
(vla-delete x)
(setq n (1+ n))
)
)
)
)
(vlax-map-collection
(vlax-get-property *AcDocument* 'groups)
'(lambda (x)
(if (< (vlax-get-property x 'count) 2)
(progn
(vla-delete x)
(setq n (1+ n))
)
)
)
)
)
(if (/= n 0)
(progn (if mod
(princ (strcat "\n共删除 " (itoa n) "个匿名组! "))
(princ (strcat "\n共删除 " (itoa n) "个空组! "))
)
(princ "耗时 ")
(princ
(- (* 86400.0 (- (getvar "date") (fix (getvar "date"))))
seconds
)
)
(princ " s!")
)
(if mod
(princ "\n未找到匿名组!")
(princ "\n未找到空组!")
)
)
(vla-endundomark *AcDocument*)
(princ)
)
(defun c:ea:Delungrp ()
(ea:delgrp t)
(princ)
)
(defun c:ea:Delnullgrp ()
(ea:delgrp nil)
(princ)
)

(defun ybl-ent-grpname (lst / g) 
  (if lst 
    (foreach item (mapcar 'vlax-ename->vla-object lst) 
      (if (= (vla-get-objectname item) "AcDbGroup") 
        (setq g        (cons (vla-get-name item) g) 
        ) 
      ) 
    ) 
  ) 
  g 
) 
(defun ybvl-addgroup (groupname) 
  (if (not 
        (vl-catch-all-error-p 
          (setq        tf (vl-catch-all-apply 
                     'vla-item 
                     (list (vla-get-groups *AcDocument*) groupname) 
                   ) 
          ) 
        ) 
      ) 
    tf 
    (vla-add 
      (vla-get-groups *AcDocument*) 
      groupname 
    ) 
  ) 
) 
(defun ea:group->pickset (groupname / ss) 
  (setq ss (ssadd)) 
  (setq group (vla-item (vla-get-groups *AcDocument*) groupname)) 
  (if (/= (vla-get-count group) 0) 
    (vlax-for i        (vla-item (vla-get-groups *AcDocument*) groupname) 
      (ssadd (vlax-vla-object->ename i) ss) 
    ) 
  ) 
  (cadr (sssetfirst nil ss)) 
  (ssgetfirst) 
                                        ;(ssget "p") 
) 
;| 
     组操作，透明命令，全局组选开关 
|; 
(defun c:EA:GroupOnOf () 
  (if (= (getvar "pickstyle") 0) 
    (progn 
      (setvar "pickstyle" 1) 
      (prompt "\n组功能启用.") 
    ) 
    (progn 
      (setvar "pickstyle" 0) 
      (prompt "\n组功能禁用.") 
    ) 
  ) 
  (princ) 
) 
 ;| 
   功能：单组选开关，可以在系统变量PICKSTYLE＝1的情况下，使单独的组变换是否整体和分散。 
|; 
(defun c:Ea:GroupSOnOf (/ e group) 
  (if (and 
        (setq e (car (entsel "\n请拾取一个组中的实体<退出>: "))) 
        (setq group (ybl-obj-reactor e)) 
        (ybl-ent-grpname group) 
      ) 
    (progn 
      (if (= 1 (cdr (assoc 71 (entget (car group))))) 
        (progn 
          (entmod (subst '(71 . 0) 
                         (assoc 71 (entget (car group))) 
                         (entget (car group)) 
                  ) 
          ) 
          (prompt "\n该实体属于的组可以单选。") 
        ) 
        (progn 
          (entmod (subst '(71 . 1) 
                         (assoc 71 (entget (car group))) 
                         (entget (car group)) 
                  ) 
          ) 
          (prompt "\n该实体属于的组已经作为整体。") 
        ) 
      ) 
    ) 
  ) 
  (princ) 
) 
 
(defun ybvl-MkGroup (ss gname / group lst group_obj) 
  (setq group (ybvl-addgroup gname)) 
  (if (/= (vla-get-count group) 0) 
    (progn 
      (vlax-for        i group 
        (setq group_obj (cons i group_obj)) 
      ) 
      (setq group_obj (reverse group_obj)) 
    ) 
  ) 
  (vlax-for ent        (activesset) 
    (if        group_obj 
      (if (not (member ent group_obj)) 
        (setq lst (cons ent lst)) 
      ) 
      (setq lst (cons ent lst)) 
    ) 
  ) 
  (if lst 
    (progn 
      (vla-AppendItems 
        group 
        (vlax-safearray-fill 
          (vlax-make-safearray 
            vlax-vbObject 
            (cons 0 (1- (length lst))) 
          ) 
          lst 
        ) 
      ) 
      (vla-get-name group) 
    ) 
  ) 
) 
(defun c:Ea:GroupMake (/ ss gname gn) 
  (ybvl-clearcset) 
  (prompt "\n请选取要组成组的实体<退出>:") 
  (if (setq ss (ssget)) 
    (progn 
      (setq gName (getstring "\n请输入组名<制匿名组>:")) 
      (if (not (setq gn        (ybvl-MkGroup 
                          ss 
                          (if (or (= gname "") 
                                  (= gname "*") 
                              ) 
                            "*" 
                            gname 
                          ) 
                        ) 
               ) 
          ) 
        (prompt        (strcat        "\n已经把选择的实体制成组，组名是 " 
                        gn 
                        "." 
                ) 
        ) 
        (princ (strcat "\n所选实体已经属于 " gName " 组.")) 
      ) 
    ) 
  ) 
  (princ) 
) 
 ;| 
  功能：去除组定义 
|; 
(defun c:Ea:GroupDel (/ e gName group) 
  (if (and 
        (setq e (car (entsel "\n请拾取一个组中的实体<退出>: "))) 
        (setq group (ybl-obj-reactor e)) 
        (ybl-ent-grpname group) 
      ) 
    (progn 
      (setq gName (vla-get-name (vlax-ename->vla-object (car group)))) 
      (entdel (car group)) 
      (prompt 
        (strcat        "\n组 " 
                gName 
                " 已经从数据库中删除。" 
        ) 
      ) 
    ) 
  ) 
  (princ) 
) 
 ;| 
  功能：不用分解直接删除组内实体 
|; 
(defun c:Ea:GroupDelEnt        (/ e) 
  (while (setq e (car (entsel "\n请拾取一个组中要删除的实体<退出>: "))) 
    (entdel e) 
  ) 
  (princ) 
) 
 ;| 
  功能：往组内添加实体 
|; 
(defun c:Ea:GroupAddEnt        (/ e gNa ss group group_obj lst glst) 
  (ybvl-clearcset) 
  (if (and 
        (setq e (car (entsel "\n请拾取一个组中的实体确定组<退出>: "))) 
        (setq group (ybl-obj-reactor e)) 
        (setq gNa (ybl-ent-grpname group)) 
        (progn 
          (prompt 
            (strcat "\n请选取要添加到组 " (car gNa) " 中的实体<退出>:") 
          ) 
          (setq ss (ssget)) 
        ) 
      ) 
    (progn 
      (setq glst (reverse (entget (car group)))) 
      (vlax-for        i (activesset) 
        (setq 
          glst (append (list (cons 340 (vlax-vla-object->ename i))) 
                       glst 
               ) 
        ) 
      ) 
      (entmod (reverse glst)) 
    ) 
  ) 
  (princ) 
) 
 ;| 
  功能：不用分解直接移出组内实体 
|; 
(defun c:Ea:GroupRemoveEnt (/ e gName group) 
  (if (and 
        (setq e (car (entsel "\n请拾取一个组中要移出的实体<退出>: "))) 
        (setq group (ybl-obj-reactor e)) 
      ) 
    (progn 
      (setq gName (ybl-ent-grpname group)) 
      (entmod (vl-remove (cons 340 e) (entget (car group)))) 
      (prompt (strcat "\n实体已经从组 " (car gName) " 移出。")) 
    ) 
  ) 
  (princ) 
) 
 ;| 
  功能：合并两个组 
  说明：合并后，第二个组定义将从数据库删除 
|; 
(defun c:Ea:GroupMerge (/ e1 e2 gNa1 gNa2 nNums ss group1 group2 glst) 
  (if (and (setq e1 (car (entsel "\n拾取第一个组内的一个实体<退出>:"))) 
           (setq group1 (ybl-obj-reactor e1)) 
           (setq gNa1 (ybl-ent-grpname group1)) 
           (if gNa1 
             (progn 
               (vla-highlight 
                 (vlax-ename->vla-object (car group1)) 
                 :vlax-false 
               ) 
               t 
             ) 
           ) 
           (setq e2 (car (entsel "\n拾取第二个组内的一个实体<退出>:"))) 
           (setq group2 (ybl-obj-reactor e2)) 
           (setq gNa2 (ybl-ent-grpname group2)) 
           (if gNa2 
             (progn 
               (vla-highlight 
                 (vlax-ename->vla-object (car group2)) 
                 :vlax-false 
               ) 
               t 
             ) 
           ) 
      ) 
    (progn 
      (setq 
        nNums (vla-get-count (vlax-ename->vla-object (car group2))) 
      ) 
      (if (> nNums 0) 
        (progn 
          (setq        glst (append (vl-member-if-not 
                               '(lambda (x) (/= (car x) 340)) 
                               (entget (car group2)) 
                             ) 
                             (reverse (entget (car group1))) 
                     ) 
          ) 
          (entmod (reverse glst)) 
          (entdel (car group2)) 
          (vla-highlight 
            (vlax-ename->vla-object (car group1)) 
            :vlax-true 
          ) 
          (prompt (strcat "\n组 " 
                          (car gNa2) 
                          " 已经合并到组 " 
                          (car gNa1) 
                          " 中。" 
                  ) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
) 
(defun ea:DelGrp (mod / n s seconds) 
  (setq        n        0 
        s        (getvar "date") 
        seconds        (* 86400.0 (- s (fix s))) 
  ) 
  (vla-startundomark *AcDocument*) 
  (if mod 
    (vlax-map-collection 
      (vlax-get-property *AcDocument* 'groups) 
      '(lambda (x) 
         (if (wcmatch (vlax-get-property x 'name) "`**") 
           (progn 
             (vla-delete x) 
             (setq n (1+ n)) 
           ) 
         ) 
       ) 
    ) 
    (vlax-map-collection 
      (vlax-get-property *AcDocument* 'groups) 
      '(lambda (x) 
         (if (< (vlax-get-property x 'count) 2) 
           (progn 
             (vla-delete x) 
             (setq n (1+ n)) 
           ) 
         ) 
       ) 
    ) 
  ) 
  (if (/= n 0) 
    (progn (if mod 
             (princ (strcat "\n共删除 " (itoa n) "个匿名组! ")) 
             (princ (strcat "\n共删除 " (itoa n) "个空组! ")) 
           ) 
           (princ "耗时 ") 
           (princ 
             (-        (* 86400.0 (- (getvar "date") (fix (getvar "date")))) 
                seconds 
             ) 
           ) 
           (princ " s!") 
    ) 
    (if        mod 
      (princ "\n未找到匿名组!") 
      (princ "\n未找到空组!") 
    ) 
  ) 
  (vla-endundomark *AcDocument*) 
  (princ) 
) 
(defun c:ea:Delungrp () 
  (ea:delgrp t) 
  (princ) 
) 
(defun c:ea:Delnullgrp () 
  (ea:delgrp nil) 
  (princ) 
)

eachy · 发表于 2009-1-4 17:01:02

Obj_lyr.lsp 部分代码

(defun string_join (strlst div /)
(vl-string-trim
div
(apply 'strcat (mapcar '(lambda (x) (strcat x div)) strlst))
)
)
(defun ea:lockedlyr (/ r d)
(while (setq d (tblnext "layer" (null d)))
(if (= (logand (cdr (assoc 70 d)) 4) 4)
(setq r (cons (cdr (assoc 2 d)) r))
)
)
;;(string_join (reverse r) ";")
(reverse r)
)
(vl-doc-export 'ea:lyrone)
(defun c:Ea:LyrLock (/ e obj lyr lyrl el ss sLyrl)
(vla-startundomark *AcDocument*)
(while (setq e (entsel "\n拾取要锁定图层上的实体<结束>:"))
(setq obj (vlax-ename->vla-object (car e))
lyr (vla-get-layer obj)
)
(if (not (member lyr lyrl))
(progn
(setq lyrl (cons lyr lyrl))
(redraw (car e) 3)
(setq el (cons (car e) el))
(ybvl-clearcset)
(setq ss (ssget "X" (list (cons 8 lyr))))
(vla-highlight (activesset) :vlax-true)
(prompt (strcat "\n选中了""
(setq sLyrl (String_Join
(reverse lyrl)
","
)
)
""层!"
)
)
)
)
)
(if lyrl
(progn
(ybvl-clearcset)
(ssget "x" (list (cons 8 sLyrl)))
(vla-highlight (activesset) :vlax-false)
(vlax-map-collection
(vla-get-layers *AcDocument*)
'(lambda (item)
(if (wcmatch (vla-get-name item) slyrl)
(progn
(if (not (vlax-ldata-get item "EA_LYR_COLOR"))
(progn
(vlax-ldata-put
item
"EA_LYR_COLOR"
(vla-get-color item)
)
(vlax-ldata-put
item
"EA_LYR_LOCK"
(vla-get-lock item)
)
(vla-put-color item 251)
(vla-put-lock item 4)
)
(if (vlax-ldata-get item "EA_LYR_COLOR")
(progn
(vla-put-color
item
(vlax-ldata-get item "EA_LYR_COLOR")
)
(vla-put-lock
item
(vlax-ldata-get item "EA_LYR_LOCK")
)
(vlax-ldata-delete item "EA_LYR_LOCK")
(vlax-ldata-delete item "EA_LYR_COLOR")
)
)
)
)
)
)
)
)
)
(vla-endundomark *AcDocument*)
(princ)
)
;|
功能：选层保留(孤立)，其他层锁定变灰色,支持多选
|;
(defun c:EA:LyrIso (/ e obj lyr ss ss1 lyrl clr el sLyrl ss2)
(vla-startundomark *AcDocument*)
(while (setq e (entsel "\n拾取要保留图层上的实体<结束>:"))
(setq obj (vlax-ename->vla-object (car e))
lyr (vla-get-layer obj)
)
(if (not (member lyr lyrl))
(progn
(setq lyrl (cons lyr lyrl))
(redraw (car e) 3)
(setq el (cons (car e) el))
(ybvl-clearcset)
(setq ss (ssget "x" (list (cons 8 lyr))))
(vla-highlight (activesset) :vlax-true)
(prompt (strcat "\n选中了""
(setq sLyrl (String_Join
(reverse lyrl)
","
)
)
""层!"
)
)
)
)
)
(if lyrl
(progn
(vlax-map-collection
(vla-get-layers *AcDocument*)
'(lambda (item)
(if (not (wcmatch (vla-get-name item) sLyrl))
(progn
(if (not (vlax-ldata-get item "EA_LYR_COLOR"))
(progn
(vlax-ldata-put
item
"EA_LYR_COLOR"
(vla-get-color item)
)
(vlax-ldata-put
item
"EA_LYR_LOCK"
(vla-get-lock item)
)
(vla-put-color item 251)
(vla-put-lock item 4)
)
)
)
(progn
(if (setq clr (vlax-ldata-get item "EA_LYR_COLOR"))
(progn
(vla-put-color
item
(vlax-ldata-get item "EA_LYR_COLOR")
)
(vla-put-lock
item
(vlax-ldata-get item "EA_LYR_LOCK")
)
)
)
)
)
)
)
(ybvl-clearcset)
(if (ssget "x" (list (cons 8 sLyrl)))
(vla-highlight (activesset) :vlax-false)
)
)
)
(vla-endundomark *AcDocument*)
(princ)
)
;|
恢复选层保留到原来状态
|;
(defun c:Ea:LyrRes (/)
(vlax-map-collection
(vla-get-layers *AcDocument*)
'(lambda (item)
(if (vlax-ldata-get item "EA_LYR_COLOR")
(progn
(vla-put-color item (vlax-ldata-get item "EA_LYR_COLOR"))
(vla-put-lock item (vlax-ldata-get item "EA_LYR_LOCK"))
(vlax-ldata-delete item "EA_LYR_LOCK")
(vlax-ldata-delete item "EA_LYR_COLOR")
)
)
)
)
(princ)
)

(defun string_join (strlst div /) 
  (vl-string-trim 
    div 
    (apply 'strcat (mapcar '(lambda (x) (strcat x div)) strlst)) 
  ) 
) 
(defun ea:lockedlyr (/ r d) 
  (while (setq d (tblnext "layer" (null d))) 
    (if        (= (logand (cdr (assoc 70 d)) 4) 4) 
      (setq r (cons (cdr (assoc 2 d)) r)) 
    ) 
  ) 
  ;;(string_join (reverse r) ";") 
  (reverse r) 
) 
(vl-doc-export 'ea:lyrone) 
(defun c:Ea:LyrLock (/ e obj lyr lyrl el ss sLyrl) 
  (vla-startundomark *AcDocument*) 
  (while (setq e (entsel "\n拾取要锁定图层上的实体<结束>:")) 
    (setq obj (vlax-ename->vla-object (car e)) 
          lyr (vla-get-layer obj) 
    ) 
    (if        (not (member lyr lyrl)) 
      (progn 
        (setq lyrl (cons lyr lyrl)) 
        (redraw (car e) 3) 
        (setq el (cons (car e) el)) 
        (ybvl-clearcset) 
        (setq ss (ssget "X" (list (cons 8 lyr)))) 
        (vla-highlight (activesset) :vlax-true) 
        (prompt        (strcat        "\n选中了"" 
                        (setq sLyrl (String_Join 
                                      (reverse lyrl) 
                                      "," 
                                    ) 
                        ) 
                        ""层!" 
                ) 
        ) 
      ) 
    ) 
  ) 
  (if lyrl 
    (progn 
      (ybvl-clearcset) 
      (ssget "x" (list (cons 8 sLyrl))) 
      (vla-highlight (activesset) :vlax-false) 
      (vlax-map-collection 
        (vla-get-layers *AcDocument*) 
        '(lambda (item) 
           (if (wcmatch (vla-get-name item) slyrl) 
             (progn 
               (if (not (vlax-ldata-get item "EA_LYR_COLOR")) 
                 (progn 
                   (vlax-ldata-put 
                     item 
                     "EA_LYR_COLOR" 
                     (vla-get-color item) 
                   ) 
                   (vlax-ldata-put 
                     item 
                     "EA_LYR_LOCK" 
                     (vla-get-lock item) 
                   ) 
                   (vla-put-color item 251) 
                   (vla-put-lock item 4) 
                 ) 
                 (if (vlax-ldata-get item "EA_LYR_COLOR") 
                   (progn 
                     (vla-put-color 
                       item 
                       (vlax-ldata-get item "EA_LYR_COLOR") 
                     ) 
                     (vla-put-lock 
                       item 
                       (vlax-ldata-get item "EA_LYR_LOCK") 
                     ) 
                     (vlax-ldata-delete item "EA_LYR_LOCK") 
                     (vlax-ldata-delete item "EA_LYR_COLOR") 
                   ) 
                 ) 
               ) 
             ) 
           ) 
         ) 
      ) 
    ) 
  ) 
  (vla-endundomark *AcDocument*) 
  (princ) 
) 
 ;| 
   功能：选层保留(孤立)，其他层锁定变灰色,支持多选 
|; 
(defun c:EA:LyrIso (/ e obj lyr ss ss1 lyrl clr el sLyrl ss2) 
  (vla-startundomark *AcDocument*) 
  (while (setq e (entsel "\n拾取要保留图层上的实体<结束>:")) 
    (setq obj (vlax-ename->vla-object (car e)) 
          lyr (vla-get-layer obj) 
    ) 
    (if        (not (member lyr lyrl)) 
      (progn 
        (setq lyrl (cons lyr lyrl)) 
        (redraw (car e) 3) 
        (setq el (cons (car e) el)) 
        (ybvl-clearcset) 
        (setq ss (ssget "x" (list (cons 8 lyr)))) 
        (vla-highlight (activesset) :vlax-true) 
        (prompt        (strcat        "\n选中了"" 
                        (setq sLyrl (String_Join 
                                      (reverse lyrl) 
                                      "," 
                                    ) 
                        ) 
                        ""层!" 
                ) 
        ) 
      ) 
    ) 
  ) 
  (if lyrl 
    (progn 
      (vlax-map-collection 
        (vla-get-layers *AcDocument*) 
        '(lambda (item) 
           (if (not (wcmatch (vla-get-name item) sLyrl)) 
             (progn 
               (if (not (vlax-ldata-get item "EA_LYR_COLOR")) 
                 (progn 
                   (vlax-ldata-put 
                     item 
                     "EA_LYR_COLOR" 
                     (vla-get-color item) 
                   ) 
                   (vlax-ldata-put 
                     item 
                     "EA_LYR_LOCK" 
                     (vla-get-lock item) 
                   ) 
                   (vla-put-color item 251) 
                   (vla-put-lock item 4) 
                 ) 
               ) 
             ) 
             (progn 
               (if (setq clr (vlax-ldata-get item "EA_LYR_COLOR")) 
                 (progn 
                   (vla-put-color 
                     item 
                     (vlax-ldata-get item "EA_LYR_COLOR") 
                   ) 
                   (vla-put-lock 
                     item 
                     (vlax-ldata-get item "EA_LYR_LOCK") 
                   ) 
                 ) 
               ) 
             ) 
           ) 
         ) 
      ) 
      (ybvl-clearcset) 
      (if (ssget "x" (list (cons 8 sLyrl))) 
        (vla-highlight (activesset) :vlax-false) 
      ) 
    ) 
  ) 
  (vla-endundomark *AcDocument*) 
  (princ) 
) 
 ;| 
   恢复选层保留到原来状态 
|; 
(defun c:Ea:LyrRes (/) 
  (vlax-map-collection 
    (vla-get-layers *AcDocument*) 
    '(lambda (item) 
       (if (vlax-ldata-get item "EA_LYR_COLOR") 
         (progn 
           (vla-put-color item (vlax-ldata-get item "EA_LYR_COLOR")) 
           (vla-put-lock item (vlax-ldata-get item "EA_LYR_LOCK")) 
           (vlax-ldata-delete item "EA_LYR_LOCK") 
           (vlax-ldata-delete item "EA_LYR_COLOR") 
         ) 
       ) 
     ) 
  ) 
  (princ) 
)

hnfsf · 发表于 2009-1-4 23:27:46

向eachy学习

xyp1964 · 发表于 2009-1-5 00:01:31

相当精彩，学习了！

taner · 发表于 2009-1-5 08:00:25

最初由 xyp1964 发布
[B]相当精彩，学习了！ [/B]

也期待院长＂脱裤子＂！

jx2008 · 发表于 2009-1-5 09:48:01

Eachy 工具集 Lisp源码详解

强，想Eachy学习，xyp1964也该把你的放出来了！

taner · 发表于 2009-1-5 09:56:01

ybvl-Str-Reverse ybvl-Str-Replace速度相当慢！还是用纯lisp快。

eachy · 发表于 2009-1-5 10:32:51

可能是第一次慢，再用就快了：）

一个简单的连续标注，用到了一楼的两个常量

(defun c:DmCon (/ p1 p2 p3 p4 p5 an an1 tf)
(setq tf t)
(if (setq p1 (getpoint "\nFirst Dim point: "))
(progn
(setq p4 p1)
(while (setq p2 (getpoint p1 "\nSecond Dim Point: "))
(if an
(setq p2 (inters p4 p5 p2 (polar p2 an1 1.) nil))
)
(if (not p3)
(setq
p3 (getpoint (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p1 p2))
"\nPosition: "
)
)
)
(if tf
(setq p5 p2
tf nil
)
)
(vla-adddimaligned
*ModelSpace*
(vlax-3d-point p1)
(vlax-3d-point p2)
(vlax-3d-point p3)
)
(setq p1 p2
an (angle p1 p2)
an1 (+ an _pi2)
)
)
)
)
(princ)
)

(defun c:DmCon (/ p1 p2 p3 p4 p5 an an1 tf) 
  (setq tf t) 
  (if (setq p1 (getpoint "\nFirst Dim point: ")) 
    (progn 
      (setq p4 p1) 
      (while (setq p2 (getpoint p1 "\nSecond Dim Point: ")) 
        (if an 
          (setq p2 (inters p4 p5 p2 (polar p2 an1 1.) nil)) 
        ) 
        (if (not p3) 
          (setq 
            p3 (getpoint (mapcar '* '(0.5 0.5 0.5) (mapcar '+ p1 p2)) 
                         "\nPosition: " 
               ) 
          ) 
        ) 
        (if tf 
          (setq        p5 p2 
                tf nil 
          ) 
        ) 
        (vla-adddimaligned 
          *ModelSpace* 
          (vlax-3d-point p1) 
          (vlax-3d-point p2) 
          (vlax-3d-point p3) 
        ) 
        (setq p1  p2 
              an  (angle p1 p2) 
              an1 (+ an _pi2) 
        ) 
      ) 
    ) 
  ) 
  (princ) 
)

yoyoho · 发表于 2009-1-7 08:33:48

赞同24,25楼的想法,拭目期待.

eachy · 发表于 2009-1-8 12:52:20

控制视口线显示

(if (not $Ea_vp_visible)
(setq $Ea_vp_visible 0)
)
(if (setq ss (ssget "X" '((0 . "viewport"))))
(progn
(setq ssl (sslength ss)
i -1
)
(if (zerop $Ea_vp_visible)
(progn
(repeat ssl
(vla-put-visible
(vlax-ename->vla-object (ssname ss (setq i (1+ i))))
:vlax-true
)
)
(setq $Ea_vp_visible 1)
)
(progn
(repeat ssl
(vla-put-visible
(vlax-ename->vla-object (ssname ss (setq i (1+ i))))
:vlax-false
)
)
(setq $Ea_vp_visible 0)
)
)
(setq ss nil
i nil
)
)
)

lxmgq · 发表于 2009-1-8 17:23:56

支持

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

[原创]：Eachy 工具集 Lisp源码 详解

[原创]：Eachy 工具集 Lisp源码详解