刚写的一个小程序发现有问题，请大神帮助

tranney

源程序如下
功能是把选择放入0-建筑底图中
(defun c:0T()
     (setq ceng "0-建筑底图")
     (PRINC "\n---将所选对象设置为")(princ ceng)(PRINC "，属性随层")
     (if (= (TBLOBJNAME "LAYER" ceng) nil)
     (command "layer" "n" ceng "c" "8" ceng "lt" "" "bylayer" ""))
     (while(setq a (ssget":s"))
     (setvar "cmdecho" 0)
     (command "change" a "" "p" "c" "bylayer" "la" ceng "lw" "bylayer" "")
     )
     (command "clayer" ceng)
     (PRINC "\n---将所选对象设置为")(princ ceng)(PRINC "，属性随层")
     (princ)
     )

发现问题，如果某层已经设置线型，并在图中linetype 为bylayer情况下， 切换到0-建筑底图 层中，原有线型就会消失
希望大神改进
思路

(defun c:0T()
     (setq ceng "0-建筑底图")
     (PRINC "\n---将所选对象设置为")(princ ceng)(PRINC "，属性随层")
     (if (= (TBLOBJNAME "LAYER" ceng) nil)
     (command "layer" "n" ceng "c" "8" ceng "lt" "" "bylayer" ""))
     (while(setq a (ssget":s"))
     (setvar "cmdecho" 0)
     判断物体所在图层是否已经设置非continue的线型，如果是
     将物体linetype转换为图层所设置的线型
     (command "change" a "" "p" "c" "bylayer" "la" ceng "lw" "bylayer" "")
     )
     (command "clayer" ceng)
     (PRINC "\n---将所选对象设置为")(princ ceng)(PRINC "，属性随层")
     (princ)
     )

跪求大神完善或者提供更好的源码

namezg

(defun c:0T (/ ceng ss en dxf lt)
        (setvar "cmdecho" 0)
        (setq ceng "0-建筑底图")
        (princ (strcat "\n---将所选对象设置为" ceng "，属性随层"))
        (if (not (tblsearch "layer" ceng))
                (command "_layer" "m" ceng "c" "8" ceng "lt" "Continuous" ceng "")
                (command "layer" "s" ceng "c" "8" "" "lt" "Continuous" ceng "")
        )
        (while (setq ss (ssget ":s"))
                (repeat (setq n (sslength ss))
                        (setq en (ssname ss (setq n (1- n))))
                        (setq dxf (entget en))
                        (if (not (cdr (assoc 6 dxf)))
                                (progn
                                        (setq lt (cdr (assoc 6 (entget (tblobjname "layer" (cdr (assoc 8 dxf)))))))
                                        (command "chprop" en "" "la" ceng "lw" "ByLayer" "lt" lt "")
                                )
                                (command "chprop" en "" "la" ceng "lw" "ByLayer" "")
                        )
                )
        )
        (princ (strcat "\n---将所选对象设置为" ceng "，属性随层"))
        (setvar "cmdecho" 1)
        (princ)
)

zyhandw

那就在改层以前，先把原来随层的线型信息提取出来，在放到0-建筑底图中后，再把它恢复到原来线型不就行了

tranney

哥，我是初学者，麻烦直接上代码，谢谢

caiqs

;;;command太差了，给你整了一段，全部费掉command
;;;师兄 QQ 361865648

(defun c:0T (/ ceng ss ent i entdat layername layent laydat ltyp lwidth
             obj)
  (setq ceng "0-建筑底图")
  (if (= (TBLOBJNAME "LAYER" ceng) nil)
    (entmakex '(
                '(0 . "LAYER")
                '(100 . "AcDbSymbolTableRecord")
                '(100 . "AcDbLayerTableRecord")
                (cons 2 ceng)
                '(70 . 0)
                '(62 . 7)
                '(6 . "Continuous")
               )
    )
;;;旧代码    (command "layer" "n" ceng "c" "8" ceng "lt" "" "bylayer" "")
  )
;;;    (setvar "cmdecho" 0)
  (entget (tblobjname "layer" "0"))
  (while (and (setq ss (VL-CATCH-ALL-APPLY 'ssget (list ":S")))
              ss
              (not (VL-CATCH-ALL-ERROR-P ss))
         )
;;;    (setvar "cmdecho" 0)
    (PRINC "\n---将所选对象设置为")
    (princ ceng)
    (PRINC "，属性随层")
    (setq i 0)
    (repeat (sslength ss) ;_遍历选择集
      (setq ent              (ssname ss i)
            i              (1+ i)
            entdat    (entget ent)
            layername (cdr (assoc 8 entdat)) ;_层名
            layent    (tblobjname "layer" layername)
            laydat    (entget layent)
            ltyp      (cdr (assoc 6 laydat)) ;_线型
            Lwidth    (cdr (assoc 370 laydat)) ;_线宽
            color     (cdr (assoc 62 laydat)) ;_颜色
      )
      (setq obj (vlax-ename->vla-object ent))

      (vla-put-color obj acbylayer) ;_颜色为随层
      (vla-put-LineWeight obj acLnWtByLayer) ;_线宽为随层
;;;      (vla-put-linetype obj "bylayer");_线型为随层
      (if (= (vla-get-linetype obj) "bylayer")
        (vla-put-linetype obj ltyp) ;_线型固定
      )
;;;      (if (= (vla-get-lineweight obj) acLnWtByLayer)
;;;        (vla-put-LineWeight obj Lwidth) ;_线宽固定
;;;      )
;;;      (if (= (vla-get-color obj) acbylayer)
;;;        (vla-put-color obj color) ;_颜色固定
;;;      )
      (vla-put-layer obj ceng)
      (vlax-release-object obj)
    )
;;;    改前(command "change" a        "" "p" "c" "bylayer" "la" ceng "lw" "bylayer" "")

  )
;;;  (command "clayer" ceng)
  (setvar "clayer" ceng)
;;;     (PRINC "\n---将所选对象设置为 ")
;;;    (princ ceng)
;;;    (PRINC " ，属性随层")
  (princ)
)

tranney

谢谢5楼给的代码，基本上快要达到效果了，增加了一句代码，最后效果见附图
(defun c:0T (/ ceng ss en dxf lt)
        (setvar "cmdecho" 0)
        (setq ceng "0-建筑底图")
        (princ (strcat "\n---将所选对象设置为" ceng "，属性随层"))
        (if (not (tblsearch "layer" ceng))
                (command "_layer" "m" ceng "c" "8" ceng "lt" "Continuous" ceng "")
                (command "layer" "s" ceng "c" "8" "" "lt" "Continuous" ceng "")
        )
        (while (setq ss (ssget ":s"))
                (repeat (setq n (sslength ss))
                        (setq en (ssname ss (setq n (1- n))))
                        (setq dxf (entget en))
                        (if (not (cdr (assoc 6 dxf)))
                                (progn
                                        (setq lt (cdr (assoc 6 (entget (tblobjname "layer" (cdr (assoc 8 dxf)))))))
                                        (command "chprop" en "" "la" ceng "lw" "ByLayer" "lt" lt "")
                                )
                                (command "chprop" en "" "la" ceng "lw" "ByLayer" "")
                        )
                )
        (command "change" a "" "p" "c" "bylayer" "la" ceng "lw" "bylayer" "");*增加本行代码后已达到要求
        )
        (princ (strcat "\n---将所选对象设置为" ceng "，属性随层"))
        (setvar "cmdecho" 1)
        (princ)
)

caiqs

tranney 发表于 2014-4-13 00:03
谢谢5楼给的代码，基本上快要达到效果了，增加了一句代码，最后效果见附图
(defun c:0T (/ ceng ss en dxf ...

你难道要的不是颜色和线宽随层，线型不随新层？

tranney

线型随新层不好，比如以前的中心线，虚线就都看不出来了

bikeboy

caiqs 发表于 2014-4-12 21:29
;;;command太差了，给你整了一段，全部费掉command
;;;师兄 QQ 361865648

如果针对图块呢？ 特别是嵌套块