程序哪里出了问题

zm880928 · 发表于 2024-10-25 19:15:25

本帖最后由 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 列表错误

xtjd · 发表于 2024-10-28 08:33:37

(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)
)

xyp1964 · 发表于 2024-10-26 15:55:07

(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)
)

(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) 
)

飞雪神光 · 发表于 2024-10-25 19:54:32

这代码粘的就跟AI写的一样

(setq excluded-layer "~穿线孔") ; 设置要排除的图层名称
(if (setq ss (ssget (list (cons 8 excluded-layer)))) ; 排除特定图层的选择过滤器

zm880928 · 发表于 2024-10-25 20:39:40

飞雪神光发表于 2024-10-25 19:54
这代码粘的就跟AI写的一样

贴出来了，没注意看，排版，我重新贴了一遍

飞雪神光 · 发表于 2024-10-25 21:35:40

(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)
)

(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) 
)

zm880928 · 发表于 2024-10-25 22:32:22

飞雪神光发表于 2024-10-25 21:35

谢谢师傅，但是好像颜色不能随层

ljpnb · 发表于 2024-10-26 14:58:14

本帖最后由 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)
)
 )

Qwer1243 · 发表于 2024-10-28 17:41:44

感谢分享，学习一下

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

[提问] 程序哪里出了问题

点评