关于 自动切换输入法 与 自动切换图层 之间的冲突 求解

669423907

首先非常感谢论坛大师们分享。
以下两个程序，一起加载后，自动切换图层就有问题了：可以自动切换到相应的图层，但不能在命令结束后自动返回之前的图层
不知道该如何化解呢？





;自动转层 SunSpring 2011-5-11 http://bbs.mjtd.com/thread-86804-1-1.html
(defun Zi_Dong_Qie_Huan_Tu_Ceng()
  ;; 图层初始化列表 内容：commands layers color linetype plottable
  (setq *doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq *lays (vla-get-layers *doc))
  (setq  *laylst
    (list         ;命令         图层  颜色   线型
          (list "dimlinear" "0标注" 3 "continuous" t)    ;线性
          (list "dimdiameter" "0标注" 3 "continuous" t)  ;直径
          (list "dimradius" "0标注" 3 "continuous" t)    ;半径
          (list "dimcontinue" "0标注" 3 "continuous" t)  ;连续
          (list "dimbaseline" "0标注" 3 "continuous" t)  ;基准
          (list "dimangular" "0标注" 3 "continuous" t)   ;角度
          (list "dimaligned" "0标注" 3 "continuous" t)   ;对齐
          (list "leader" "0标注" 3 "continuous" t)       ;引线
          (list "qleader" "0标注" 3 "continuous" t)      ;引线
          (list "mleader" "0标注" 3 "continuous" t)      ;多重引线
          (list "dimarc" "0标注" 3 "continuous" t)       ;弧长
          (list "dimordinate" "0标注" 3 "continuous" t)  ;坐标标注
          (list "qdim" "0标注" 3 "continuous" t)         ;快速标注
          (list "tolerance" "0标注" 3 "continuous" t)    ;形位公差标注
          (list "text" "文字" 253 "continuous" t)
          (list "mtext" "文字" 253 "continuous" t)
          (list "dtext" "文字" 253 "continuous" t)
          (list "ray" "1不打印" 44 "continuous" t)       ;射线
          (list "xline" "1不打印" 44 "continuous" t)     ;构造线
          (list "hatch" "0填充" 11 "continuous" t)      ;填充
          (list "bhatch" "0填充" 11 "continuous" t)     ;填充
          (list "dimcenter" "0中心线" 1 "center" t)   ;圆心标记
         ;(list "point" "点" 4 "continuous" t)
         ;(list "xref" "引用" 7 "continuous" t)
         ;(list "pline" "多义线" 2 "center" t)
    )
  )
  (setq OldLayer nil)
  (setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))
  (mapcar '(lambda (x) (vlr-command-reactor nil x))
    (list  '((:vlr-commandWillStart . xlr-start))
    '((:vlr-commandEnded . xlr-end))
    '((:vlr-commandCancelled . xlr-cancel))
    )
  )
  (vlr-editor-reactor nil '((:vlr-commandwillstart . xlr-edit)))
)
;————————————————————
(defun xlr-edit(call callback / n)
  (foreach n *laylst
    (if  (= (strcase (car callback)) (strcase (car n)))
      (apply 'xsetlays (cdr n))
    )
  )
)
;————————————————————
(defun xlr-start(calling-reactor xlr-startinfo / n)
  (foreach n *laylst
    (if (= (strcase (car xlr-startinfo)) (strcase (car n)))
      (apply 'xsetlays (cdr n))
    )
  )
)
;————————————————————
(defun xlr-end(calling-reactor xlr-endinfo / cmd)
  (setq cmd (car xlr-endinfo))
  (if (member cmd *cmdlst)
    (if oldlayer
      (progn
        (setvar "clayer" oldlayer)
        (setq oldlayer nil)
      )
    )
  )
)
;————————————————————
(defun xlr-cancel(calling-reactor xlr-cancelinfo / cmd)
  (setq cmd (car xlr-cancelinfo))
  (if (member cmd *cmdlst)
    (if oldlayer
      (progn
        (setvar "clayer" oldlayer)
        (setq oldlayer nil)
      )
    )
  )
)
;————————————————————
(defun xsetlays(lay-nam color ltype plotk / layobj ltypesobj)
  (defun layeron (layername / layerdata)
    (setq layerdata (entget (tblobjname "LAYER" layername)))
    (if (< (cdr (assoc 62 layerdata)) 0)
      (progn
        (setq layerdata (subst
                          (cons 62 (- 0 (cdr (assoc 62 layerdata))))
                          (assoc 62 layerdata)
                          layerdata
                        )
        )
        (entmod layerdata)
      )
    )
  )
  (if (tblobjname "layer" lay-nam)
    (progn
      (if (/= (strcase (getvar "clayer")) (strcase lay-nam))
        (setq oldlayer (getvar "clayer"))
        (progn
          (if (not oldlayer)
            (setq oldlayer lay-nam)
          )
        )
      )
      (layeron lay-nam)
      (setvar "clayer" lay-nam)
    )
    (progn
      (vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list *lays lay-nam)))
      (setq layobj (vla-item *lays lay-nam))
      (if (not (tblobjname "ltype" ltype)) ;添加线型.
        (progn
          (setq ltypesobj (vla-get-linetypes *doc))
          (vla-load ltypesobj ltype (findfile "acad.lin"))  ;>>>　要加强，在多个*.lin寻找
          (vlax-release-object ltypesobj)
        )
      )
      (vla-put-layeron layobj :vlax-true)
      (vla-put-lock layobj :vlax-false)
      (vla-put-color layobj color)
      (if (= (strcase (getvar "clayer")) (vl-cmdf "layer" "on" "" "")(strcase lay-nam)) ;解冻
        (vla-put-freeze layobj :vlax-false)
      )
      (vla-put-linetype layobj LTYPE)
      (vla-put-plottable layobj (if plotk :vlax-true :vlax-false))
    )
  )
)
(Zi_Dong_Qie_Huan_Tu_Ceng)





;CAD输入法自动切换
;请在操作系统中设置输入法热键：ctrl+shift+0切换英文，ctrl+shift+1切换中文
;fyw12345 2018-4-2 http://bbs.mjtd.com/thread-176934-1-1.html
;guangdonglbq 2021-5-20 http://bbs.mjtd.com/thread-183420-1-1.html
(vl-load-reactors)
(setq Scriptshell (vlax-create-object "WScript.Shell"))

;ctrl+shift+0切换英文
(defun ying_wen(reactor_object listCommand) (StartInputMethod (car listCommand) "+^0") )


;ctrl+shift+1切换中文
(defun zhong_wen(reactor_object listCommand) (StartInputMethod (car listCommand) "+^1") )


(defun StartInputMethod(strCommand strInputMethodKey / listEditCommands la)
        (setq strCommand (strcase strCommand T) )
        (setq strCommand (vl-string-subst "" "-" strCommand))
        (setq strCommand (vl-string-subst "" "_" strCommand))
        (setq listEditCommands (list
;命令列表
"ddedit" ;编辑单行文字、多行文字、标注文字、属性定义和特征控制框
"mtedit" ;编辑多行文字
"text" ;写单行文字
"dtext" ;写单行文字
"qleader" ;引线标注
"mleader" ;多重引线标注
"mtext" ;写多行文字
"find" ;查找和替换
"saveas" ;保存副本
"textedit" ;
))
  (if (member strCommand listEditCommands)
                (vlax-invoke Scriptshell "SendKeys" strInputMethodKey)
  )
)

(defun startIMEScript(a b)
(vlr-command-reactor nil
        '((:vlr-commandWillStart . zhong_wen) ;启动CAD命令时
                 (:vlr-commandEnded . ying_wen) ;完成CAD命令时
                 (:vlr-commandCancelled . ying_wen) ;取消CAD命令时
                 (:vlr-commandFailed . ying_wen) ;无法完成CAD命令时
         )
)
)

(defun EndIMEScript(a b )
        (vlr-remove-all :vlr-command-reactor)
)

(startIMEScript nil nil)

(vlax-invoke Scriptshell "SendKeys" "+^0") ;加载时，启用英文输入法

(vlr-lisp-reactor nil
        '((:vlr-lispWillStart . EndIMEScript) ;;启动lisp时
                 (:vlr-lispEnded . startIMEScript) ;;完成lisp时
                 (:vlr-lispCancelled . startIMEScript) ;;取消lisp时
         )
)
(princ)

669423907

麻烦大神们帮看看啦

669423907

哪位大师帮忙改一下啦

guangdonglbq

原因在于2个程序都设置了vlr-command-reactor，两者有冲突，需要把相关功能写到一起。

(mapcar '(lambda (x) (vlr-command-reactor nil x))
    (list  '((:vlr-commandWillStart . xlr-start))
    '((:vlr-commandEnded . xlr-end))
    '((:vlr-commandCancelled . xlr-cancel))
    )
  )


(vlr-command-reactor nil
        '((:vlr-commandWillStart . zhong_wen) ;启动CAD命令时
                 (:vlr-commandEnded . ying_wen) ;完成CAD命令时
                 (:vlr-commandCancelled . ying_wen) ;取消CAD命令时
                 (:vlr-commandFailed . ying_wen) ;无法完成CAD命令时
         )
)

你在明经发帖子发了1784个，远比一般人都多……在明经混了这么久，简单的东西自己动手处理的应该也学会了，就不帮你改代码了。

669423907

guangdonglbq 发表于 2021-6-12 07:58
原因在于2个程序都设置了vlr-command-reactor，两者有冲突，需要把相关功能写到一起。

(mapcar '(lambd ...

谢谢大师回复，我虽然论坛泡的久，但是只懂些非常简单的皮毛。我先试试

669423907

guangdonglbq 发表于 2021-6-12 07:58
原因在于2个程序都设置了vlr-command-reactor，两者有冲突，需要把相关功能写到一起。

(mapcar '(lambd ...

我弄不来，还望guangdonglbq大师帮忙改一下啦，谢谢你了

669423907

路过的大神，麻烦帮改一下拉，不胜感激。两个程序都很好用，我实在是看不懂哦

429014673

自动切换输入法 与 自动切换图层 之间的冲突    解决了吗？

669423907

大神们帮忙改一下呗

ㄘ丶转裑ㄧ灬

你换阿甘的输入法切换
http://bbs.mjtd.com/thread-183157-1-1.html