标注与图框图层相同，请求修改
原SunSpring大师的增强标注，想修改下（让标注与图框图层相同）http://bbs.mjtd.com/forum.php?mod=viewthread&tid=100053&highlight=%D4%F6%C7%BF%B1%EA%D7%A22处红色部份为我修改的，不行，请高手帮助
(setq *en2obj* vlax-ename->vla-object)
;;;图框位置
(defun titleplace (titlename p0 / entdata entgrp entname i n pb pc ptlist titlescale txdata)
(if (setq entgrp (ssget "x" (list '(0 . "insert") (cons 2 titlename))))
(repeat (setq n (sslength entgrp))
(setq entname (ssname entgrp (setq n (1- n))))
(setq titlescale (vla-get-XScaleFactor (*en2obj* entname)))
(setq clay (vla-get-layer (*en2obj* entname)))
(setq ptlist (append (ax:getboundingbox entname) (list titlescale)))
(setq txdata (append (list ptlist) txdata))
)
)
(setq i 0)
(if (and p0 txdata)
(while (< i (length txdata))
(setq pb (nth 0 (nth i txdata)))
(setq pc (nth 1 (nth i txdata)))
(if (and
(> (nth 0 p0) (nth 0 pb))
(< (nth 0 p0) (nth 0 pc))
(> (nth 1 p0) (nth 1 pb))
(< (nth 1 p0) (nth 1 pc))
)
(progn
(setvar "dimscale" (nth 2 (nth i txdata)))
(setq i (length txdata))
)
(setvar "dimscale" 1.0)
)
(setq i (+ i 1))
)
)
(setvar "clayer" clay)
)
;;;返回图元对象边框的最大和最小点
(defun ax:getboundingbox (entname / entpl entpr ptlist)
(vla-getboundingbox (vlax-ename->vla-object entname) 'entpl 'entpr)
(setq ptlist (mapcar 'vlax-safearray->list (list entpl entpr)))
(mapcar '(lambda (x) (trans x 0 1)) ptlist)
)
(defun getentdxf (ent dxf)
(cond
((= (type ent) 'ename)
(cdr (assoc dxf (entget ent '("*"))))
)
((= (type ent) 'vla-object)
(cdr (assoc dxf (entget (vlax-vla-object->ename ent) '("*"))))
)
)
)
;;;创建对齐线性标注
(defun c:dal ()
(saverror)
(setvar "cmdecho" 1)
(command ".dimaligned")
(while (wcmatch (getvar "cmdnames") (strcase "*dimaligned*"))
(command pause)
(titleplace "GB_A*" (getvar "lastpoint"))
)
(restore)
(princ)
)
;;;创建角度标注
(defun c:dan ()
(saverror)
(setvar "cmdecho" 1)
(command ".dimangular")
(while (wcmatch (getvar "cmdnames") (strcase "*dimangular*"))
(command pause)
(titleplace "GB_A*" (getvar "lastpoint"))
)
(restore)
(princ)
)
;;;创建圆和圆弧的直径标注
(defun c:ddi ( / ent)
(saverror)
(setq ent (entsel "选择圆弧或圆:"))
(titleplace "GB_A*" (cadr ent))
(setvar "cmdecho" 1)
(command ".dimdiameter" ent)
(while (wcmatch (getvar "cmdnames") (strcase "*dimdiameter*"))
(command pause)
)
(restore)
(princ)
)
;;;创建线性标注
(defun c:dli ()
(saverror)
(setvar "cmdecho" 1)
(command ".dimlinear")
(while (wcmatch (getvar "cmdnames") (strcase "*dimlinear*"))
(command pause)
(titleplace "GB_A*" (getvar "lastpoint"))
)
(restore)
(princ)
)
;;;创建坐标点标注
(defun c:dor ( / pt)
(saverror)
(setq pt (getpoint "指定点坐标:"))
(titleplace "GB_A*" pt)
(setvar "cmdecho" 1)
(command ".dimordinate" pt)
(while (wcmatch (getvar "cmdnames") (strcase "*dimordinate*"))
(command pause)
)
(restore)
(princ)
)
;;;创建圆和圆弧的半径标注
(defun c:dra ( / ent)
(saverror)
(setq ent (entsel "选择圆弧或圆:"))
(titleplace "GB_A*" (cadr ent))
(setvar "cmdecho" 1)
(command ".dimradius" ent)
(while (wcmatch (getvar "cmdnames") (strcase "*dimradius*"))
(command pause)
)
(restore)
(princ)
)
;;;引线命令
(defun c:le ( / pt)
(saverror)
(setvar "cmdecho" 1)
(setq pt (getpoint "指定第一个引线点:"))
(titleplace "GB_A*" pt)
(command ".qleader" pt)
(restore)
(princ)
)
;;;填充命令
(defun c:bh ()
(saverror)
(setvar "cmdecho" 1)
(command "-hatch")
(while (wcmatch (getvar "cmdnames") (strcase "*hatch*"))
(command pause)
)
(titleplace "GB_A*" (getvar "lastpoint"))
(vla-put-PatternScale (*en2obj* (entlast)) (getvar "dimscale"))
(restore)
(princ)
)
;;;出错退出
(defun errexit (s)
(restore)
(princ)
)
;;;出错处理
(defun saverror ()
(setq olderr *error*)
(setq *error* errexit)
(setvar "cmdecho" 0)
(setq clayer (getvar "clayer"))
(setq lastent (entlast))
)
;;;出错恢复
(defun restore ()
(redraw)
(setq *error* olderr)
(setvar "clayer" clayer)
(princ)
)
本帖最后由 gaics 于 2020-9-19 10:19 编辑
刘炎华 发表于 2020-9-19 00:18
大致有原因了
单个图层的图框它是可以变过去的
工作中，我们用的图框是多个图层了，有些图还是叠起来的 ...
找到原因就好办了，在昨天代码的基础上改一下titleplace子函数就ok！
(defun titleplace (titlename p0 / entdata
entgrp entnamei n pb
pc ptlist titlescale txdata
clay
)
(if (setq entgrp (ssget "x" (list '(0 . "insert") (cons 2 titlename))))
(repeat (setq n (sslength entgrp))
(setq entname (ssname entgrp (setq n (1- n))))
(setq titlescale (vla-get-XScaleFactor (*en2obj* entname)))
(setq clay (vla-get-layer (*en2obj* entname)));;;获取图框图层
(setq
ptlist (append (ax:getboundingbox entname) (list titlescale) (list clay));;;图层名加入ptlist
)
(setq txdata (append (list ptlist) txdata))
)
)
(setq i 0)
(if (and p0 txdata)
(while (< i (length txdata))
(setq pb (nth 0 (nth i txdata)))
(setq pc (nth 1 (nth i txdata)))
(if (and
(> (nth 0 p0) (nth 0 pb))
(< (nth 0 p0) (nth 0 pc))
(> (nth 1 p0) (nth 1 pb))
(< (nth 1 p0) (nth 1 pc))
)
(progn
(setvar "dimscale" (nth 2 (nth i txdata)))
(setvar "clayer" (nth 3 (nth i txdata)));;;设置当前图层
(setq i (length txdata))
)
(setvar "dimscale" 1.0)
)
(setq i (+ i 1))
)
)
)
本帖最后由 gaics 于 2020-9-18 08:32 编辑
初步判断问题在于第二次进入(titleplace "GB_A*" (getvar "lastpoint"))命令创建选择集时出错。增加一个判断吧，不二次调用titleplace的话就能正常运行，修改见蓝色字体部分。
SunSpring的原贴也存在同样问题。
我只放了你的部分代码。
(setq *en2obj* vlax-ename->vla-object)
;;;图框位置
(defun titleplace (titlename p0 / entdata entgrp entname i n pb pc ptlist titlescale txdata clay)
(if (setq entgrp (ssget "x" (list '(0 . "insert") (cons 2 titlename))))
(repeat (setq n (sslength entgrp))
(setq entname (ssname entgrp (setq n (1- n))))
(setq titlescale (vla-get-XScaleFactor (*en2obj* entname)))
(setq clay (vla-get-layer (*en2obj* entname)));;;;;
(setq ptlist (append (ax:getboundingbox entname) (list titlescale)))
(setq txdata (append (list ptlist) txdata))
)
)
(setq i 0)
(if (and p0 txdata)
(while (< i (length txdata))
(setq pb (nth 0 (nth i txdata)))
(setq pc (nth 1 (nth i txdata)))
(if (and
(> (nth 0 p0) (nth 0 pb))
(< (nth 0 p0) (nth 0 pc))
(> (nth 1 p0) (nth 1 pb))
(< (nth 1 p0) (nth 1 pc))
)
(progn
(setvar "dimscale" (nth 2 (nth i txdata)))
(setq i (length txdata))
)
(setvar "dimscale" 1.0)
)
(setq i (+ i 1))
)
)
(setvar "clayer" clay);;;
(setq x t)
)
;;;返回图元对象边框的最大和最小点
(defun ax:getboundingbox (entname / entpl entpr ptlist)
(vla-getboundingbox (vlax-ename->vla-object entname) 'entpl 'entpr)
(setq ptlist (mapcar 'vlax-safearray->list (list entpl entpr)))
(mapcar '(lambda (x) (trans x 0 1)) ptlist)
)
(defun getentdxf (ent dxf)
(cond
((= (type ent) 'ename)
(cdr (assoc dxf (entget ent '("*"))))
)
((= (type ent) 'vla-object)
(cdr (assoc dxf (entget (vlax-vla-object->ename ent) '("*"))))
)
)
)
;;;创建线性标注
(defun c:dli (/ x)
(saverror)
(setvar "cmdecho" 1)
(command ".dimlinear")
(while (wcmatch (getvar "cmdnames") (strcase "*dimlinear*"))
(command pause)
(if(= x nil)(titleplace "GB_A*" (getvar "lastpoint")))
)
(restore)
(princ)
)
;;;出错退出
(defun errexit (s)
(restore)
(princ)
)
;;;出错处理
(defun saverror ()
(setq olderr *error*)
(setq *error* errexit)
(setvar "cmdecho" 0)
(setq clayer (getvar "clayer"))
(setq lastent (entlast))
)
;;;出错恢复
(defun restore ()
(redraw)
(setq *error* olderr)
(setvar "clayer" clayer)
(princ)
) gaics 发表于 2020-9-18 08:16
初步判断问题在于第二次进入(titleplace "GB_A*" (getvar "lastpoint"))命令创建选择集时出错。增加一个判 ...
还是不能与图框同层呢？辛苦帮我再找下原因 本帖最后由 gaics 于 2020-9-18 10:38 编辑
刘炎华 发表于 2020-9-18 10:07
还是不能与图框同层呢？辛苦帮我再找下原因
我只改了“dli”这个命令。测试可以改图层。
你那边有什么提示呢？
有没有设置过“dimlayer”这个系统变量？或者其他插件有没有强制给标注归层？
抱歉！回复不及时，没外网，只能用手机回复您
我用的是2010，没有这个变量，生成的标注到前层了
好像改了后titleplace不作用了，标注时比例不变了
可以上传个您调试过的附件吗？
gaics 发表于 2020-9-18 10:34
我只改了“dli”这个命令。测试可以改图层。
你那边有什么提示呢？
有没有设置过“dimlayer”这个系统 ...
可以上传个您调试过的附件吗？
本帖最后由 gaics 于 2020-9-18 15:06 编辑
刘炎华 发表于 2020-9-18 12:40
可以上传个您调试过的附件吗？
跟附件关系不大，应该是代码、变量的冲突
gaics 发表于 2020-9-18 15:01
跟附件关系不大，应该是代码、变量的冲突
麻烦您再传个lsp我试下
我改变量名试了也不行呢 本帖最后由 gaics 于 2020-9-18 15:42 编辑
刘炎华 发表于 2020-9-18 15:40
麻烦您再传个lsp我试下
我改变量名试了也不行呢
跟我前面回复的代码没区别的。关闭cad再试试。先把你原来的lsp卸载