请教一下,自动图层和最大块包围框lisp冲突，谁能帮看看

听见天晴 · 发表于 2024-6-24 19:55:20

2个程序都是从论坛下载的，发现他们同时启动加载就会冲突，使用最大块包围框的程序时，就会弹出如下对话框；
并且CAD就一直弹框报错，关都要强行关掉。

我还发现这个包围框的程序和【Gu_xl】版主的自动切换图层也会冲突，估计是这个包围框程序的问题？
有大神能帮忙改一下吗，让他们可以兼容使用，本人不会写程序，只是想找一些程序来提高工作效率，谢谢大家~
以下是自动图层

(defun xlr-autolayer ()
;; 图层初始化列表内容：commands layers color linetype plottable
(setq *doc (vla-get-activedocument (vlax-get-acad-object)))
(setq *lays (vla-get-layers *doc))
(setq *laylst
(list (list "DIMANGULAR" "DIM" 3 "continuous" T)
(list "DIMALIGNED" "DIM" 3 "continuous" T)
(list "DIMBASELINE" "DIM" 3 "continuous" T)
(list "DIMCENTER" "DIM" 3 "continuous" T)
(list "DIMCONTINUE" "DIM" 3 "continuous" T)
(list "DIMDIAMETER" "DIM" 3 "continuous" T)
(list "DIMLINEAR" "DIM" 3 "continuous" T)
(list "DIMORDINATE" "DIM" 3 "continuous" T)
(list "DIMRADIUS" "DIM" 3 "continuous" T)
(list "QDIM" "DIM" 3 "continuous" T)
(list "QLEADER" "DIM" 3 "continuous" T)
(list "DTEXT" "TXT" 3 "continuous" T)
(list "MTEXT" "TXT" 3 "continuous" T)
(list "TEXT" "TXT" 3 "continuous" T)
;(list "BHATCH" "填充" 9 "continuous" T)
;(list "HATCH" "填充" 9 "continuous" T)
;(list "POINT" "点" 4 "continuous" T)
;(list "XLINE" "辅助线" 8 "continuous" T)
;(list "LINE" "0" NIL "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 nil)
(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 nil)
(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 (= oldlayer nil)
(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")) (command "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))
)
)
)
(xlr-autolayer) ;加载启动!

(defun xlr-autolayer () 
  ;; 图层初始化列表 内容：commands layers color linetype plottable 
  (setq *doc (vla-get-activedocument (vlax-get-acad-object))) 
  (setq *lays (vla-get-layers *doc)) 
  (setq  *laylst 
    (list (list "DIMANGULAR" "DIM" 3 "continuous" T) 
          (list "DIMALIGNED" "DIM" 3 "continuous" T) 
          (list "DIMBASELINE" "DIM" 3 "continuous" T) 
          (list "DIMCENTER" "DIM" 3 "continuous" T) 
          (list "DIMCONTINUE" "DIM" 3 "continuous" T) 
          (list "DIMDIAMETER" "DIM" 3 "continuous" T) 
          (list "DIMLINEAR" "DIM" 3 "continuous" T) 
          (list "DIMORDINATE" "DIM" 3 "continuous" T) 
          (list "DIMRADIUS" "DIM" 3 "continuous" T) 
          (list "QDIM" "DIM" 3 "continuous" T) 
          (list "QLEADER" "DIM" 3 "continuous" T) 
          (list "DTEXT" "TXT" 3 "continuous" T) 
          (list "MTEXT" "TXT" 3 "continuous" T) 
          (list "TEXT" "TXT" 3 "continuous" T) 
         ;(list "BHATCH" "填充" 9 "continuous" T) 
         ;(list "HATCH" "填充" 9 "continuous" T) 
         ;(list "POINT" "点" 4 "continuous" T) 
         ;(list "XLINE" "辅助线" 8 "continuous" T) 
         ;(list "LINE" "0" NIL "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 nil) 
      (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 nil) 
      (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 (= oldlayer nil) 
            (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")) (command "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)) 
    ) 
  ) 
) 
(xlr-autolayer)        ;加载启动!

以下是最大块包围框

;;;几何关系判断
(defun c:tt (/ box e i ss lst bound rects)
(defun ebox (e / pa pb)
(and (= 'ename (type e)) (setq e (vlax-ename->vla-object e)))
(vlax-invoke-method e 'GetBoundingBox 'pa 'pb)
(setq pa (trans (vlax-safearray->list pa) 0 1)
pb (trans (vlax-safearray->list pb) 0 1)
)
(list pa pb)
)
(defun area (pts) (apply '* (cdr (reverse (apply 'mapcar (cons '- pts)))))) ;_求面积
(defun pt4 (pt2)
(list (car pt2) (list (caadr pt2) (cadar pt2)) (cadr pt2) (list (caar pt2) (cadadr pt2)))
) ;_对角点生成四角点
(defun PtInPoly (pt pts)
(equal pi
(abs
(apply '+ (mapcar '(lambda (x y) (rem (- (angle pt x) (angle pt y)) pi)) (cons (last pts) pts) pts))
)
1e-6
)
) ;_点是否在凸多边形内（角度法）
;;
(setq ss (ssget '((0 . "INSERT"))))
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(setq lst (cons (ebox e) lst)) ;_提取边界对角点，不生产矩形
)
(setq lst (vl-sort lst '(lambda (x1 x2) (> (area x1) (area x2))))) ;_按面积大小排序
(while lst
(setq rects (cons (car lst) rects)) ;_矩形对角点集
(setq bound (pt4 (car lst))) ;_矩形边界
(setq lst (vl-remove-if '(lambda (x) (and (PtInPoly (car x) bound) (PtInPoly (cadr x) bound))) (cdr lst))) ;_移除大矩形边界内的小矩形
)
(mapcar '(lambda (x) (command-s "rectang" (car x) (cadr x))) rects) ;_批量生成矩形
(princ)
)

;;;几何关系判断 
(defun c:tt (/ box e i ss lst bound rects) 
  (defun ebox (e / pa pb) 
    (and (= 'ename (type e)) (setq e (vlax-ename->vla-object e))) 
    (vlax-invoke-method e 'GetBoundingBox 'pa 'pb) 
    (setq pa (trans (vlax-safearray->list pa) 0 1) 
          pb (trans (vlax-safearray->list pb) 0 1) 
    ) 
    (list pa pb) 
  ) 
  (defun area (pts) (apply '* (cdr (reverse (apply 'mapcar (cons '- pts)))))) ;_求面积 
  (defun pt4 (pt2) 
    (list (car pt2) (list (caadr pt2) (cadar pt2)) (cadr pt2) (list (caar pt2) (cadadr pt2))) 
  ) ;_对角点生成四角点 
  (defun PtInPoly (pt pts) 
    (equal pi 
           (abs 
             (apply '+ (mapcar '(lambda (x y) (rem (- (angle pt x) (angle pt y)) pi)) (cons (last pts) pts) pts)) 
           ) 
           1e-6 
    ) 
  ) ;_点是否在凸多边形内（角度法） 
  ;; 
  (setq ss (ssget '((0 . "INSERT")))) 
  (repeat (setq i (sslength ss)) 
    (setq e (ssname ss (setq i (1- i)))) 
    (setq lst (cons (ebox e) lst)) ;_提取边界对角点，不生产矩形 
  ) 
  (setq lst (vl-sort lst '(lambda (x1 x2) (> (area x1) (area x2))))) ;_按面积大小排序 
  (while lst 
    (setq rects (cons (car lst) rects)) ;_矩形对角点集 
    (setq bound (pt4 (car lst))) ;_矩形边界 
    (setq lst (vl-remove-if '(lambda (x) (and (PtInPoly (car x) bound) (PtInPoly (cadr x) bound))) (cdr lst))) ;_移除大矩形边界内的小矩形 
  ) 
  (mapcar '(lambda (x) (command-s "rectang" (car x) (cadr x))) rects) ;_批量生成矩形 
  (princ) 
)

自贡黄明儒 · 发表于 2024-6-25 09:33:48

反应器慎用呀，有些毫不相干的，也有影响。

gzcsun · 发表于 2024-6-25 08:30:45

自动图层有问题，也没什么用，关闭就是了。
不明白自动图层有什么作用？
DIM
TEXTLAYER
也可以分层。

e2002 · 发表于 2024-6-25 08:51:55

自动图层以前还是用的，在 AutoCAD 陆续提供了 DIMLAYER，TEXTLAYER， HPLAYER 之后，基本上可以不需要了。

gzcsun · 发表于 2024-6-25 09:16:37

我从来不用自动图层
要分的图元会在插件加上图层，颜色。
自动图层命令也只能改 command 生成的图元。

自贡黄明儒 · 发表于 2024-6-25 09:32:15

e2002 发表于 2024-6-25 08:51
自动图层以前还是用的，在 AutoCAD 陆续提供了 DIMLAYER，TEXTLAYER， HPLAYER 之后，基本上可以不需要了。

哪个版本开始提供的呀？

听见天晴 · 发表于 2024-6-25 21:46:04

gzcsun 发表于 2024-6-25 08:30
自动图层有问题，也没什么用，关闭就是了。
不明白自动图层有什么作用？
DIM

我还真不知道高版本已经做成自带的命令了。。。谢谢

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

[提问] 请教一下,自动图层和最大块包围框lisp冲突，谁能帮看看

本帖子中包含更多资源

相关帖子

点评