;;;*******************************************************************************
;;;功能: 将同种线型归为同一层,目的是减少层的数量
(defun C:DecreaseLayers (/ *BLK CMDECHO1 LTYPES)
  ;;1 解冻 解锁 开 所有图层
  (defun HH:Mylayer ()
    (acet-layerp-mode T)
    (acet-layerp-mark T)
    (command "_.Layer" "Thaw" "*" "U" "*" "ON" "*" "")
  )
  ;;2  coaying______________________________________________________________________
  ;; ▓ (lt:layer-useable-restore)
  ;; [功能] 恢复图层状态
  (defun lt:layer-restore ()
    (acet-layerp-mark nil)
    (command "_.layerp")
  )
  ;;3  获得特定符号表的列表。
  ;;   有效符号表名称为Layer,Ltype,Viewx,Style,Block,Appid,Ucs,Dimstyle和Vport。
  (defun xyp-get-tblnext (table-name / lst d)
    (while (setq d (tblnext table-name (null d)))
      (setq lst (cons (cdr (assoc 2 d)) lst))
    )
    (reverse lst)
    lst
  )
  ;;4  功能:块随层 highflybird
  (defun BlockByLayerColor (/ *APP *BLK *DOC ENT I OBJ SEL)
    (defun change-Layer (obj / name blks currentLayer)
      (setq currentLayer (getvar "clayer"))
      (vla-put-layer obj currentLayer)
      ;(vla-put-color obj AcByLayer)
      (if (or
     (= (vla-get-objectname obj) "AcDbBlockReference")
     (= (vla-get-objectname obj) "AcDbMInsertBlock")
   ) 
 (progn
   (foreach Att (vlax-invoke Obj 'GetAttributes)
     (vla-put-Layer Att currentLayer)
     ;(vla-put-color Att AcByLayer)
   )
   (setq name (vla-get-name obj)) ; 取得块名
   (setq blks (vla-item *BLK name))
   (vlax-for n blks
     (change-Layer n)
   )
   (vla-update obj)  ; 用以更新数据，或程序完成后用Regen
 )
      )
    )
    (setq *App (vlax-get-acad-object))
    (setq *Doc (vla-get-ActiveDocument *APP))
    (setq *BLK (vla-get-blocks *DoC))
    (setq i 0)
    ;;(save_layer_status)
    ;;(unlock_all_layers)
    (if (setq sel (ssget "X" '((0 . "INSERT"))))
      (repeat (sslength sel)
 (setq ent (ssname sel i))
 (setq obj (vlax-ename->vla-object ent))
 (change-Layer obj)
 (setq i (1+ i))
      )
    )
    ;;(restore_layer_status)
    (princ)
  )
  ;;5  功能:根据线型改层
  (defun LayerByLtype (Ltypes / D LAYERNAME LAYERNAME0 LTYPE LTYPE0 SS)
    (repeat (length Ltypes)
      (setq LType0     (car Ltypes)
     Ltypes     (cdr Ltypes)
     LayerName0 nil
     d        nil
      )
      (while (setq d (tblnext "layer" (null d)))
 (setq LayerName (cdr (assoc 2 d)))
 (setq LType (cdr (assoc 6 d)))
 (if (equal LType0 LType)
   (if LayerName0
     (progn (setq ss (ssget "X" (list (cons 8 LayerName))))
     (if ss
       (vl-cmdf "_.Chprop" ss "" "layer" LayerName0 "")
     )
     )
     (progn (setq LayerName0 LayerName)
     (setq ss (ssget "X" (list (cons 6 LType0))))
     (if ss
       (vl-cmdf "_.Chprop" ss "" "layer" LayerName0 "")
     )
     )
   )
   nil
 )
      )
    )
  )
  ;;6  清理
  (defun HH:purge ()
    (repeat 3
      (vla-purgeall
 (vla-get-activedocument (vlax-get-acad-object))
      )
    )
  )
  ;;7  本程序主程序
  (setq cmdecho1 (getvar "cmdecho"))
  (setvar "cmdecho" 0)
  (vl-load-com)
  (command "_.UNDO" "BE")
  (HH:Mylayer)
  (BlockByLayerColor)
  (setq Ltypes (xyp-get-tblnext "Ltype"))
  (LayerByLtype Ltypes)
  (HH:purge)
  (lt:layer-restore)
  (command "_.UNDO" "E")
  (setvar "cmdecho" cmdecho1)
  (gc)
)
;;;*******************************************************************************