程序哪里出了问题
本帖最后由 zm880928 于 2024-10-25 20:38 编辑(defun c:ttt(/ en layadd+c obj objname ss sslen st excluded-layer)
(defun layadd+c (layer color)
;新建图层函数
(if (null (tblobjname "LAYER" layer))
(entmake (list
'(0. "LAYER")
'(100. "AcDbSymbolTableRecord")
'(100. "AcDbLayerTableRecord")
'(6. "CONTINUOUS") ;线型
'(70. 0) ;图层状态
(cons 62 color) ;颜色
(cons 2 layer) ;图层名
))
)
)
(princ "图元分层")
(setvar "cmdecho" 0)
(setq excluded-layer "穿线孔") ; 设置要排除的图层名称
(if (setq ss (ssget '((8. "!". excluded-layer)))) ; 排除特定图层的选择过滤器
(progn
;(layadd+c "0-XG-Layer01" 1) ;新建xg层，图层颜色=1（红）
;(layadd+c "0-XG-CENTER" 5) ;新建XG-CENTER层，图层颜色=5（蓝）
;(layadd+c "0-XG-BHATCH" 8) ;新建XG-BHATCH层，图层颜色=8（灰）
;(layadd+c "0-XGTXT" 3) ;新建xgtxt层，图层颜色=3（绿）
;(layadd+c "0-XGDIM" 7) ;新建xgdim层，图层颜色=7（白）
(setq sslen (sslength ss)) ;图元数量
(setq st -1)
(repeat sslen
(setq
en (ssname ss (setq st (1+ st)))
obj (vlax-ename->vla-object en)
objname (strcase (vla-get-objectname obj) t)
)
(vla-put-color obj (vla-get-color (vla-get-layer obj))) ; 将图元颜色设为随层
(cond
((wcmatch objname "*dimension,acdbleader") (vla-put-layer obj "XGDIM"))
((wcmatch objname "*text") (vla-put-layer obj "XGTXT"))
((wcmatch objname "*hatch") (vla-put-layer obj "XG-BHATCH"))
((and
(wcmatch objname "*circle,*line")
(wcmatch (strcase (vla-get-linetype obj) t) "dashed*,hidden*")
)
(vla-put-layer obj "XG-CENTER"))
(t (vla-put-layer obj "XG-Layer01"))
)
)
(princ (strcat "\n共有" (itoa sslen) "个图元整理分层成功"))
)
(princ "\n未选中图元")
)
(setvar "cmdecho" 1)
(prin1)
)
输入命令还没开始选择就提示一下错误
图元分层undo 当前设置: 自动 = 开，控制 = 全部，合并 = 是，图层 = 是输入要放弃的操作数目或 [自动(A)/控制(C)/开始(BE)/结束(E)/标记(M)/后退(B)] <1>: e ssget 列表错误
(defun c:ttt(/ os ss)
(setvar "cmdecho" 0)
(if(setq ss(ssget '((8 . "~穿线孔"))))
(progn
;1新建程序所需图层
(mapcar
(function
(lambda(x)
(entmakex
(list
'(0 . "LAYER")'(100 . "AcDbSymbolTableRecord")'(100 . "AcDbLayerTableRecord")'(6 . "CONTINUOUS")'(70 . 0)
(cons 62(cadr x))(cons 2(car x))
)
)
)
)
'(("0-XG-Layer01" 1)("0-XG-CENTER" 5)("0-XG-BHATCH" 8)("0-XGTXT" 3)("0-XGDIM" 7))
)
;2图元依类分层
(mapcar
(function
(lambda(x / on)
(setq on(vla-get-objectname x))
(vla-put-layer x
(cond
((wcmatch on "*Dim*,*Leader")"0-XGDIM")
((wcmatch on "*Text")"0-XGTXT")
((wcmatch on "*Hatch")"0-XG-BHATCH")
((wcmatch on "*Text")"0-XGTXT")
((wcmatch on "*Text")"0-XGTXT")
((and(wcmatch on "*Circle,*Line")(wcmatch(vla-get-linetype x)"DASHED*,HIDDEN*"))"0-XG-CENTER")
(t "0-XG-Layer01")
)
)
(vla-put-Color x 256)
)
)
(setq os(mapcar 'vlax-ename->vla-object(vl-remove-if 'listp(mapcar 'cadr(ssnamex ss)))))
)
(princ(strcat "\n共有" (itoa(length os)) "个图元整理分层成功"))
)
)
(prin1)
) (defun c:tt ()
"图元分层"
(defun dxf (code e) (cdr (assoc code (entget e))))
(defun SubUpd (e c v)
(entmod (subst (cons c v) (assoc c (entget e)) (entget e)))
(entupd e)
)
(defun mklaco (la co)
(entmake (list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
(cons 62 co) ;颜色
(cons 2 la) ;图层名
)
)
)
(if (setq ss (ssget '((8 . "~穿线孔")))) ; 排除特定图层
(progn
(mklaco "XG-LAYER01" 1)
(mklaco "XG-CENTER" 5)
(mklaco "XG-BHATCH" 8)
(mklaco "XG-TXT" 3)
(mklaco "XG-DIM" 7)
(setq i -1)
(repeat (setq nn (sslength ss))
(setq s1 (ssname ss (setq i (1+ i))))
(setq et (strcase (DXF 0 s1)))
(SubUpd s1 62 256) ; 图元颜色随层
(cond ((wcmatch et "*DIMENSION,ACDBLEADER")
(SubUpd s1 8 "XG-DIM")
)
((wcmatch et "*TEXT")
(SubUpd s1 8 "XG-TXT")
)
((wcmatch et "HATCH")
(SubUpd s1 8 "XG-BHATCH")
)
((and (wcmatch et "CIRCLE,*LINE")
(setq lt (DXF 6 s1))
(wcmatch (strcase lt) "DASHED*,HIDDEN*")
)
(SubUpd s1 8 "XG-CENTER")
)
(t (SubUpd s1 8 "XG-LAYER01"))
)
)
(princ (strcat "\n共有" (itoa nn) "个图元整理分层成功"))
)
)
(princ)
) 这代码粘的 就跟AI写的一样(setq excluded-layer "~穿线孔") ; 设置要排除的图层名称
(if (setq ss (ssget (list (cons 8 excluded-layer)))) ; 排除特定图层的选择过滤器 飞雪神光 发表于 2024-10-25 19:54
这代码粘的 就跟AI写的一样
贴出来了，没注意看，排版，我重新贴了一遍 (defun c:ttt(/ en layadd+c obj objname ss sslen st excluded-layer)
(defun layadd+c (layer color)
;新建图层函数
(if (null (tblobjname "LAYER" layer))
(entmake (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(6 . "CONTINUOUS") ;线型
'(70 . 0) ;图层状态
(cons 62 color) ;颜色
(cons 2 layer) ;图层名
)
)
)
)
(princ "图元分层")
(setvar "cmdecho" 0)
(setq excluded-layer "~穿线孔") ; 设置要排除的图层名称
(if (setq ss (ssget (list (cons 8 excluded-layer)))) ; 排除特定图层的选择过滤器
(progn
(layadd+c "XG-Layer01" 1) ;新建xg层，图层颜色=1（红）
(layadd+c "XG-CENTER" 5) ;新建XG-CENTER层，图层颜色=5（蓝）
(layadd+c "XG-BHATCH" 8) ;新建XG-BHATCH层，图层颜色=8（灰）
(layadd+c "XGTXT" 3) ;新建xgtxt层，图层颜色=3（绿）
(layadd+c "XGDIM" 7) ;新建xgdim层，图层颜色=7（白）
(setq sslen (sslength ss)) ;图元数量
(setq st -1)
(repeat sslen
(setq
en (ssname ss (setq st (1+ st)))
obj (vlax-ename->vla-object en)
objname (strcase (vla-get-objectname obj) t)
)
(vla-put-color obj (vla-get-color (vlax-ename->vla-object(tblobjname "layer" (vla-get-layer obj))))) ; 将图元颜色设为随层
(cond
((wcmatch objname "*dimension,acdbleader") (vla-put-layer obj "XGDIM"))
((wcmatch objname "*text") (vla-put-layer obj "XGTXT"))
((wcmatch objname "*hatch") (vla-put-layer obj "XG-BHATCH"))
((and
(wcmatch objname "*circle,*line")
(wcmatch (strcase (vla-get-linetype obj) t) "dashed*,hidden*")
)
(vla-put-layer obj "XG-CENTER")
)
(t (vla-put-layer obj "XG-Layer01"))
)
)
(princ (strcat "\n共有" (itoa sslen) "个图元整理分层成功"))
)
(princ "\n未选中图元")
)
(setvar "cmdecho" 1)
(prin1)
) 飞雪神光 发表于 2024-10-25 21:35
谢谢师傅，但是好像颜色不能随层:lol 本帖最后由 ljpnb 于 2024-10-26 15:18 编辑
(setq dxf (subst (cons 62 256) (assoc 62 dxf) dxf))
(entmod dxf)
或者
(setq col (vla-get-truecolor obj))
(if (< (vla-get-colorindex col) 256)
(progn
(vla-put-colorindex col 256)
(vla-put-truecolor obj col)
)
)
感谢分享，学习一下
页:
[1]