命令反应器(标注和填充自动归层)

eachy · 发表于 2014-11-22 15:28:56

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

早先的一个程序，很简单，执行 Dim Hatch 命令前设置到特定图层

;;设置当前图层
(defun Reactor:SetLayer (name / lay)
(setq retlay (getvar "clayer"))
(if (tblsearch "layer" name)
(progn
(setq lay
(vla-item (vla-get-layers
(vla-get-activedocument (vlax-get-acad-object))
)
name
)
)
(if (= :vlax-True (vla-get-lock lay))
(progn
(setq $laylock :vlax-True)
(vla-put-lock lay :vlax-False)
)
)
(if (= :vlax-False
(vla-get-layeron lay)
)
(progn
(setq $layon :vlax-false)
(vla-put-layeron lay :vlax-true)
)
)
(if (= :vlax-True (vla-get-Freeze lay))
(progn
(setq $layfrz :vlax-true)
(vla-put-Freeze lay :vlax-false)
)
)
(vla-put-activelayer
(vla-get-activedocument (vlax-get-acad-object))
lay
)
)
(progn
(vla-add (vla-get-layers
(vla-get-activedocument (vlax-get-acad-object))
)
name
)
(vla-put-activelayer
(vla-get-activedocument (vlax-get-acad-object))
(vla-item (vla-get-layers
(vla-get-activedocument (vlax-get-acad-object))
)
name
)
)
)
)
)
;;命令结束或者中断后恢复图层状态
;;;upon completion of command restores *layers* to previous state
(defun Reactor:Restorelayer (reactor info / cmd layobj)
(setq cmd (car info))
(if
(and
(wcmatch
(strcase cmd)
"*DIM,*DIMLINEAR,*DIMALIGNED,*DIMORDINATE,*DIMRADIUS,*DIMDIAMETER,*DIMANGULAR,*DIMBASELINE,*DIMCONTINUE,*QDIM,*LEADER,*QLEADER,*HATCH"
)
retlay
)
(progn
(vla-setvariable
(vla-get-activedocument (vlax-get-acad-object))
"clayer"
retlay
)
(if $layon
(vla-put-LayerOn layoff 0) ;_turn it off again
)
(if $layfrz
(vla-put-Freeze layfreeze 1) ;_freeze it again
) ;_end if
(if $laylock
(vla-put-Lock laylock 1) ;_Lock it again
) ;_end if
(setq $layon nil
$layfrz nil
$laylock nil
retlay nil
)
)
)
)
;;命令开始设置当前图层
(defun Reactor:Autolayer (reactor info / cmd)
(setq cmd (strcase (car info))) ;_ get command name
(cond
((wcmatch cmd "*HATCH") ;_is the command "*hatch"?
(Reactor:SetLayer "HATCH") ;_填充图层
)
((wcmatch
(strcase (car info))
"*DIM,*DIMLINEAR,*DIMALIGNED,*DIMORDINATE,*DIMRADIUS,*DIMDIAMETER,*DIMANGULAR,*DIMBASELINE,*DIMCONTINUE,*QDIM,*LEADER,*QLEADER"
)
(Reactor:SetLayer "DIM") ;_标注图层
)
(t)
)
)
(if (not ea:Hatch_Dim_reactor)
(setq ea:Hatch_Dim_reactor
(VLR-Command-reactor
nil
'((:VLR-commandWillStart . Reactor:Autolayer) ;_命令开始执行
(:VLR-commandEnded . Reactor:Restorelayer) ;_命令结束执行
(:VLR-commandCancelled . Reactor:Restorelayer) ;_命令中断执行
)
)
)
)
(princ)

;;设置当前图层 
(defun Reactor:SetLayer        (name / lay) 
  (setq retlay (getvar "clayer")) 
  (if (tblsearch "layer" name) 
    (progn 
      (setq lay 
             (vla-item (vla-get-layers 
                         (vla-get-activedocument (vlax-get-acad-object)) 
                       ) 
                       name 
             ) 
      ) 
      (if (= :vlax-True (vla-get-lock lay)) 
        (progn 
          (setq $laylock :vlax-True) 
          (vla-put-lock lay :vlax-False) 
        ) 
      ) 
      (if (= :vlax-False 
             (vla-get-layeron lay) 
          ) 
        (progn 
          (setq $layon :vlax-false) 
          (vla-put-layeron lay :vlax-true) 
        ) 
      ) 
      (if (= :vlax-True (vla-get-Freeze lay)) 
        (progn 
          (setq $layfrz :vlax-true) 
          (vla-put-Freeze lay :vlax-false) 
        ) 
      ) 
      (vla-put-activelayer 
        (vla-get-activedocument (vlax-get-acad-object)) 
        lay 
      ) 
    ) 
    (progn 
      (vla-add (vla-get-layers 
                 (vla-get-activedocument (vlax-get-acad-object)) 
               ) 
               name 
      ) 
      (vla-put-activelayer 
        (vla-get-activedocument (vlax-get-acad-object)) 
        (vla-item (vla-get-layers 
                    (vla-get-activedocument (vlax-get-acad-object)) 
                  ) 
                  name 
        ) 
      ) 
    ) 
  ) 
) 
;;命令结束或者中断后恢复图层状态 
;;;upon completion of command restores *layers* to previous state 
(defun Reactor:Restorelayer (reactor info / cmd layobj) 
  (setq cmd (car info)) 
  (if 
    (and 
      (wcmatch 
        (strcase cmd) 
        "*DIM,*DIMLINEAR,*DIMALIGNED,*DIMORDINATE,*DIMRADIUS,*DIMDIAMETER,*DIMANGULAR,*DIMBASELINE,*DIMCONTINUE,*QDIM,*LEADER,*QLEADER,*HATCH" 
      ) 
      retlay 
    ) 
     (progn 
       (vla-setvariable 
         (vla-get-activedocument (vlax-get-acad-object)) 
         "clayer" 
         retlay 
       ) 
       (if $layon 
         (vla-put-LayerOn layoff 0) ;_turn it off again 
       ) 
       (if $layfrz 
         (vla-put-Freeze layfreeze 1) ;_freeze it again 
       ) ;_end if 
       (if $laylock 
         (vla-put-Lock laylock 1) ;_Lock it again 
       ) ;_end if 
       (setq $layon nil 
             $layfrz nil 
             $laylock nil 
             retlay nil 
       ) 
     ) 
  ) 
) 
;;命令开始设置当前图层 
(defun Reactor:Autolayer (reactor info / cmd) 
  (setq cmd (strcase (car info))) ;_ get command name 
  (cond 
    ((wcmatch cmd "*HATCH") ;_is the command "*hatch"? 
     (Reactor:SetLayer "HATCH") ;_填充图层 
    ) 
    ((wcmatch 
       (strcase (car info)) 
       "*DIM,*DIMLINEAR,*DIMALIGNED,*DIMORDINATE,*DIMRADIUS,*DIMDIAMETER,*DIMANGULAR,*DIMBASELINE,*DIMCONTINUE,*QDIM,*LEADER,*QLEADER" 
     ) 
     (Reactor:SetLayer "DIM") ;_标注图层 
    ) 
    (t) 
  ) 
) 
(if (not ea:Hatch_Dim_reactor) 
  (setq        ea:Hatch_Dim_reactor 
         (VLR-Command-reactor 
           nil 
           '((:VLR-commandWillStart . Reactor:Autolayer) ;_命令开始执行 
             (:VLR-commandEnded . Reactor:Restorelayer) ;_命令结束执行 
             (:VLR-commandCancelled . Reactor:Restorelayer) ;_命令中断执行 
            ) 
         ) 
  ) 
) 
(princ)

/db_自贡黄明儒_ · 发表于 2014-11-22 16:16:53

其它可以类推了，向站长学习

无痕 · 发表于 2014-11-25 03:05:40

记得是以前很早就写了的吧

aihuyujian · 发表于 2015-1-20 14:23:14

最近研究反应器来学习学习

kkt123 · 发表于 2015-2-26 12:19:08

最近研究反应器来学习学习:):)

愤怒的小鸟 · 发表于 2019-10-20 19:25:20

这个如何运行呢？
命令: ap APPLOAD 已成功加载 4.lsp。
命令: ; 错误: 读入的 (八进制) 字符不正确: 0

代敬龙 · 发表于 2020-2-5 22:42:04

好程序，好好学习

网事如尘 · 发表于 2020-3-6 07:33:01

学习了，感谢分享

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

[教学] 命令反应器(标注和填充自动归层)

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

评分