[LISP程序]：发个转换图层的工具

hb198075

主要功能是可以用自定义快捷键转换到指定图层,如果有选择目标,则是转换目标到该层,如果没有,则把该层设为当前层.
可以自定义对应图层的生成属性,也就是当图形中没有该层时,会按此属性来新建一个图层.
设置的快捷键为"TCSET"
(注:"layerXL.lsp"文件请最后加载!)

mico_ye

不错

zx0sl

不知道能不能下载

xjlmlxbq

不能下载 ?

abc900

感谢楼主的无私奉献

lfx49

感谢，努力挣钱

userzhluserzhl

no function definition: HB_REGDIST

yoyoho

楼主麻烦检视一下程序
,无法下载?

jiayuxiaozhang

好东西
可惜钱不够
经济萧条啊

hb198075

我也不知道为什么下不了，我自己试了能下的。
把代码贴在下面吧。
下面是通用函数库，懒得分离了，都贴上来。
[pcode=lisp,true]
;;;个人通用函数
;;;
;;;
;;;
;;;
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;----全局变量----;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(VL-LOAD-COM)
;;;加载 ActiveX
(setq vlaxDoc           (vla-get-ActiveDocument
                     (vlax-get-Acad-Object)
                   )
      *ModelSpace* (vla-get-ModelSpace vlaxDoc)
)
;;;获取模型空间的指针

(setq n_lst (list "")
      m_hbdraw nil ;是否重绘图形
      )

(setq olderr *error*)
;;;保存出错函数
;;;(setq cmold (getvar "cmdecho"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;程序初始及结束设置
(defun hb_start        (lst is /)
  (if is
    (progn
      (vla-StartUndoMark vlaxDoc)
      (setq n_lst (HB_SETVAR lst))
      (setq *error* hb_error)
    )
    (progn
      (setq *error* olderr)
      (HB_SETVAR n_lst)
      (vla-EndUndoMark VLAXDOC)
    )
  )
)


;;;自定义出错函数
(defun hb_error        (a /)
  (if
    (not
      (member a
              '("函数被取消" "Function cancelled" "quit / exit abort")
      )
    )
     (princ a)
  )
  (if m_redraw
    (cond
      ((member (type m_redraw) (list 'ename ))
       (redraw m_reDraw 4)
       (setq m_reDraw nil)
      )
      ((= (type m_redraw) 'list)
       (MAPCAR '(LAMBDA (itm) (redraw itm 4))
               m_redraw
       )
       (setq m_reDraw nil)
      )
    )
  )
  (if m_hbdraw
    (redraw)
  )
  (if m_delss
    (progn
      (vl-cmdf "_.erase" m_delss "")
      (setq m_delss nil)
    )
  )
  (if m_setFirst
    (sssetfirst nil nil)
  )
  (HB_SETVAR n_lst)
  (setq *error* olderr)
  (vla-EndUndoMark VLAXDOC)
)

;;;三维点转二维点
(defun hb_3dpto2dp (point / rel)
  (list (car point) (cadr point))
)

;;;获得当前UCS相对于WCS的角度
(defun hb_ucsAng (/ rel)
  (ANGLE (trans '(0 0) 1 0) (trans '(1 0) 1 0))
)

;;;将度转换为弧度
(defun hb_duToHu (du) (* pi (/ du 180.0)))

;;;将弧度转换为度
(defun hb_HuToDu (hu) (* 180 (/ hu pi)))

;;;将表转换为包含双精度实数数组
(defun hb_ltoa (ptsList / arraySpace sArray)
                                        ; 给以双精度实数表示的二维点数组分配空间
  (setq        arraySpace
         (vlax-make-safearray
           vlax-vbdouble                ; 元素类型
           (cons 0
                 (- (length ptsList) 1)
           )                                ; 数组维数
         )
  )
  (setq sArray (vlax-safearray-fill arraySpace ptsList))
                                        ; 返回数组变体
  (vlax-make-variant sArray)
)


;;;使用ActiveX绘制多段线
(defun hb_drawPL (plst / n point dp)
  (setq n 0)
  (repeat (length plst)
    (setq point        (nth n plst)
          point        (HB_3DPTO2DP (trans point 1 0))
          dp        (append dp point)
    )
    (setq n (+ n 1))
  )
  (setq dp (HB_LTOA dp))
  (vla-AddLightWeightPolyline
    *MODELSPACE*
    dp
  )
)


;;;注册表操作函数
(defun hb_Reg (lst keyWz isRead / key mykey n na rd rel)
  (setq        key   (vlax-product-key)
        mykey (strcat "HKEY_CURRENT_USER\\\" key "\\\HbSet\\\" keyWz)
  )
  (setq n 0)
  (if isRead
    (repeat (length lst)
      (setq na (nth n lst))
      (setq rd (VL-REGISTRY-READ mykey (car na)))
      (if rd
        (setq rel (cons (cons (car na) rd) rel))
        (setq rel (cons na rel))
      )
      (setq n (+ n 1))
    )
    (repeat (length lst)
      (setq na (nth n lst))
      (VL-REGISTRY-WRITE mykey (car na) (cdr na))
      (setq n (+ n 1))
    )
  )
  (REVERSE rel)
)

;;;注册表项删除
(defun hb_RegDel (lst keyWz / key mykey n x)
  (setq        key   (vlax-product-key)
        mykey (strcat "HKEY_CURRENT_USER\\\" key "\\\HbSet\\\" keyWz)
  )
  (if lst
    (MAPCAR '(LAMBDA (x) (VL-REGISTRY-DELETE mykey x)) lst)
    (VL-REGISTRY-DELETE mykey)
  )
)


;;;获得注册表单项值
(defun hb_Reg_GetVal (keywz name def / key mykey rel)
  (setq        key   (vlax-product-key)
        mykey (strcat "HKEY_CURRENT_USER\\\" key "\\\HbSet\\\" keyWz)
  )
  (if (setq rel (VL-REGISTRY-READ mykey name))
    rel
    def
  )
)


;;;设置注册表单项值
(defun hb_Reg_SetVal (keywz name val / key mykey)
  (setq        key   (vlax-product-key)
        mykey (strcat "HKEY_CURRENT_USER\\\" key "\\\HbSet\\\" keyWz)
  )
  (VL-REGISTRY-WRITE mykey name val)
)

;;;设置系统变量
(defun hb_setVar (lst / n na rel layzt)
  (if lst
    (progn
      (setq n 0)
      (repeat (length lst)
        (setq na (nth n lst))
        (setq rel (cons (cons (car na) (getvar (car na))) rel))        
        (setvar (car na) (cdr na))
        (setq n (+ n 1))
      )
    )
  )
  rel
)

;;;设置图层状态
(defun hb_setLayerZt (layna free on / zt1 zt2 na layob rel1 rel2 rel)
  (if free
    (setq zt1 :vlax-true)
    (setq zt1 :vlax-false)
  )
  (if on
    (setq zt2 :vlax-true)
    (setq zt2 :vlax-false)
  )
  (setq        na    (TBLOBJNAME "layer" layna)
        layob (vlax-ename->vla-object na)
        rel1  (vla-get-Freeze layob)
        rel2  (vla-get-layeron layob)
  )
  (if (/= (getvar "clayer") layna)
    (vla-put-freeze layob zt1)
    (if free (princ "\n无法冻结当前图层!"))
  )
  (vla-put-layeron layob zt2)
  (if (= rel1 :vlax-true)
    (setq rel1 t)
    (setq rel1 nil)
  )
  (if (= rel2 :vlax-true)
    (setq rel2 t)
    (setq rel2 nil)
  )
  (list rel1 rel2)
)








;;;获得系统变量
(defun hb_getVar (lst / n na rel)
  (if lst
    (progn
      (setq n 0)
      (repeat (length lst)
        (setq na (nth n lst))
        (setq rel (cons (cons na (getvar na)) rel))
        (setq n (+ n 1))
      )
    )
  )
  rel
)


;;;判断是否为插入块
(defun hb_isKuai (na / rel lst a n)
  (setq lst (ACET-TABLE-NAME-LIST (list "block" 1 4 16)))
  (setq n 0)
  (repeat (length lst)
    (setq a (nth n lst))
    (if        (= a na)
      (setq rel 1)
    )
    (setq n (+ n 1))
  )
  rel
)


;;;计算中点
(defun hb_zhongDian (dian1 dian2 / ax ay)
  (setq        ax (- (car dian2) (car dian1))
        ay (- (cadr dian2) (cadr dian1))
  )
  (list (+ (car dian1) (/ ax 2)) (+ (cadr dian1) (/ ay 2)))
)


;;;获取一个字符串中的数字
(defun hb_getShuzi (str / sz n len tmp cha isdian rel)
  (if str
    (progn
      (setq sz "1234567890.")
      (setq n 1)
      (setq len (strlen str))
      (repeat len
        (setq cha (substr str n 1))
        (if (VL-STRING-SEARCH cha sz)
          (progn
            (if        (= cha ".")
              (if isdian
                (setq cha "")
                (setq isdian t)
              )
            )
            (if        tmp
              (setq tmp (strcat tmp cha))
              (setq tmp cha)
            )
          )
        )
        (setq n (1+ n))
      )
    )
  )
  (setq rel tmp)
)




;;;从选择集中获取数据列表
(defun hb_getShuju (ss lst / m n tmp tmp0 rel na ent a0)
  (setq n 0)
  (repeat (sslength ss)
    (setq na  (ssname ss n)
          ent (entget na)
    )
    (setq m (length lst))
    (repeat (length lst)
      (setq m (- m 1))
      (setq a0 (cdr (assoc (nth m lst) ent)))
      (if (not tmp)
        (setq tmp (list a0))
        (setq tmp (append (list a0) tmp))
      )
    )
    (if        (not rel)
      (setq rel (list tmp))
      (setq rel (cons tmp rel))
    )
    (setq tmp nil)
    (setq n (+ n 1))
  )
  rel
)

(defun hb_getNameText (na / rel ent lx lst)
  (setq lst '("TEXT" "MTEXT" "ATTDEF"))
  ;;"ATTRIB" "INSERT"))
  (setq        ent (entget na)
        lx  (cdr (assoc 0 ent))
  )
  (if (member lx lst)
    (setq rel (cdr (assoc 1 ent)))
  )
  rel
)

;;;获取目标中的文字信息
(defun hb_getText (na / rel ent lx tmp lst)
  (setq        lst '("TEXT" "MTEXT" "ATTDEF" "ATTRIB" "INSERT")
  )

  (setq        ent (entget na)
        lx  (cdr (assoc 0 ent))
  )
  (cond
    ((member lx '("TEXT" "MTEXT" "ATTDEF" "ATTRIB"))
     (setq rel (cdr (assoc 1 ent)))
    )
    ((= lx "INSERT")
     (if (and (setq tmp (assoc 66 ent))
              (= (cdr tmp) 1)
         )
       (setq tmp (acet-insert-attrib-get (list na 1))
             rel (nth 1 (nth 0 tmp))
       )
       (princ "选择的目标不含有效信息！")
     )
    )
    (t (princ "选择的目标不含有效信息！"))
  )
  rel
)




(defun hb_tableList (na is / rel tmp i)
  (setq rel (list (cdr (assoc 2 (tblnext na t)))))
  (while (not i)
    (setq tmp (cdr (assoc 2 (tblnext na))))
    (if        tmp
      (if is
        (if (/= (substr tmp 1 1) "*")
          (setq rel (append rel (list tmp)))
        )
        (setq rel (append rel (list tmp)))
      )
      (setq i t)
    )
  )
  rel
)

(defun hb_addCons (ent cns at / n rel nlt)
  (setq nlt (length ent))
  (setq n (- nlt 1))
  (if (> nlt at)
    (repeat nlt
      (setq rel (cons (nth n ent) rel))
      (if (= n at)
        (setq rel (cons cns rel))
      )
      (setq n (1- n))
    )
    (progn
      (setq rel (cons cns rel))
      (repeat nlt
        (setq rel (cons (nth n ent) rel))
        (setq n (1- n))
      )
    )
  )
  rel
)

(defun hb_getEntCount (ent ename / tmp n rel cns)
  (foreach cns ent
    (if        (= (car cns) ename)
      (progn
        (setq tmp (cdr cns))
        (setq rel (cons tmp rel))
      )
    )
  )
  (reverse rel)
)

(defun hb_list_fanXu (ent /)
  (REVERSE ent)
)

(defun hb_list_enaDel (lst ena / tmp rel)
  (foreach tmp lst
    (if        (/= (car tmp) ena)
      (setq rel (cons tmp rel))
    )
  )
  (reverse rel)
)

(defun hb_list_replaceAt (lst nitem at / tmp rel n)
  (setq n 0)
  (repeat (length lst)
    (setq tmp (nth n lst))
    (if        (= n at)
      (setq rel (cons nitem rel))
      (setq rel (cons tmp rel))
    )
    (setq n (1+ n))
  )
  (reverse rel)
)

(defun hb_list_delAt (lst at / tmp rel n)
  (setq n 0)
  (repeat (length lst)
    (setq tmp (nth n lst))
    (if        (/= n at)
      (setq rel (cons tmp rel))
    )
    (setq n (1+ n))
  )
  (REVERSE rel)
)

(defun hb_list_replaceEnt (ent lst / tmp)
  (foreach tmp lst
    (if        (assoc (car tmp) ent)
      (setq ent (subst tmp (assoc (car tmp) ent) ent))
      (setq ent        (REVERSE ent)
            ent        (cons tmp ent)
            ent        (REVERSE ent)
      )
    )
  )
  ent
)

(defun hb_list_replaceFor (lst newlst cns / tmp rel n)
  (setq n 0)
  (foreach tmp lst
    (if        (= (car tmp) cns)
      (setq rel        (cons (cons cns (nth n newlst)) rel)
            n        (1+ n)
      )
      (setq rel (cons tmp rel))
    )
  )
  (reverse rel)
)

;;;获得某元素在列表中第一次出现的位置
(defun hb_list_at (itm lst / rel n)
  (setq n 0)
  (while (and (setq tmp (nth n lst))
              (null rel)
         )
    (if        (equal itm tmp)
      (setq rel n)
    )
    (setq n (1+ n))
  )
  rel
)

(defun hb_ss_copy (ss / rel tmp n)
  (setq n 0)
  (setq rel (ssadd))
  (if ss
    (progn
      (repeat (sslength ss)
        (setq tmp (ssname ss n))
        (ssadd tmp rel)
        (setq n (1+ n))
      )
    )
  )
  rel
)

(defun hb_ssToLst (ss / na ent ena n rel)
  (setq n 0)
  (repeat (sslength ss)
    (setq na  (ssname ss n)
          ent (entget na)
          ena (cdr (assoc -1 ent))
    )
    (setq rel (cons ena rel)
          n   (1+ n)
    )
  )
  (reverse rel)
)


(defun hb_ss_delByEnt
       (ss lst is / tmp n rel na ent tmpar tmpdr tmpent pd)
  (if ss
    (progn
      (setq rel (ssadd))
      (setq n 0)
      (repeat (sslength ss)
        (setq na  (ssname ss n)
              ent (entget na)
              pd  t
        )
        (foreach tmp lst
          (setq        tmpar (car tmp)
                tmpdr (cdr tmp)
          )
          (if
            (and (setq tmpent (assoc tmpar ent))
                 (WCMATCH (cdr tmpent) tmpdr)
            )
             ()
             (setq pd nil)
          )
        )
        (if is
          (if (not pd)
            (ssadd na rel)
          )
          (if pd
            (ssadd na rel)
          )
        )
        (setq n (1+ n))
      )
    )
  )
  rel
)

(defun hb_dlg_image (key color sldna / dimx dimy)
  (setq        dimx (dimx_tile key)
        dimy (dimy_tile key)
  )
  (start_image key)
  (fill_image 0 0 dimx dimy color)
  (if sldna
    (slide_image 0 0 dimx dimy sldna)
  )
  (end_image)
)


(defun hb_get_entX (ent cnt / rel e)
  (foreach e ent
    (if        (= (car e) cnt)
      (setq rel (cons (cdr e) rel))
    )
  )
  (reverse rel)
)


(defun hb_get_SupDir (/ path n)
  (setq        path (getvar "ACADPREFIX")
        n    (VL-STRING-SEARCH ";" path)
        path (substr path 1 n)
        path (strcat path "\\\")
  )
)

(defun hb_getFileDate (fna / rel tmp file fpath)
  (setq fpath (findfile fna))
  (if fpath
    (if        (setq file (open fpath "r"))
      (progn
        (while (setq tmp (read-line file))
          (setq rel (cons tmp rel))
        )
        (setq rel (reverse rel))
        (close file)
      )
    )
    (princ (strcat "\n无法找到\"" fna "\"该文件！"))
  )
  rel
)


(defun hb_setMyVar
                   (na          vla        /     file  path  fna        tmp   str
                    is          rel        wtvla sjlst n          qm        hm    sj
                   )
  (setq        path  (HB_GET_SUPDIR)
        fna   (strcat path "hb_var102.ini")
        is    t
        na    (strcase na)
        wtvla (strcat na "=" vla)
        sjlst (HB_GETFILEDATE fna)
        n     0
  )
  (while (and is (< n (length sjlst)))
    (setq tmp (nth n sjlst))
    (if        (/= (substr tmp 1 1) ";")
      (if (setq sj (HB_STRING_BYCHAR tmp "="))
        (progn
          (setq qm (strcase (car sj)))
          (if (= na qm)
            (setq sjlst        (subst wtvla tmp sjlst)
                  is        nil
                  rel        (cdr sj)
            )
          )
        )
      )
    )
    (setq n (1+ n))
  )
  (if is
    (setq sjlst (append sjlst (list wtvla)))
    (setq is t)
  )
  (setq file (open fna "w"))
  (MAPCAR '(LAMBDA (itm) (write-line itm file))
          sjlst
  )
  (close file)
  rel
)




(defun hb_getMyVar (na / file path fna tmp str is rel sj)
  (setq        path (HB_GET_SUPDIR)
        fna  (strcat path "hb_var102.ini")
        is   t
        na   (strcase na)
  )
  (if (setq file (open fna "r"))
    (progn
      (while (and is (setq tmp (read-line file)))
        (setq tmp (strcase tmp))
        (if (/= (substr tmp 1 1) ";")
          (if (setq sj (HB_STRING_BYCHAR tmp "="))
            (progn
              (setq qm (car sj)
                    hm (cadr sj)
              )
              (if (= na qm)
                (setq rel hm
                      is  nil
                )
              )
            )
          )
        )
      )
      (close file)
    )
  )
  rel
)

(defun hb_string_byChar        (str char / n lft rig rel)
  (if (setq n (VL-STRING-SEARCH char str))
    (setq lft (substr str 1 n)
          rig (substr str (+ n 2) (- (strlen str) n 1))
          rel (list lft rig)
    )
  )
  rel
)

(defun hb_dlg_listAdd (key lst /)
  (start_list key)
  (MAPCAR 'add_list lst)
  (end_list)
)

(defun hb_dlg_start (dlgname dlg wz / rel dlgloaded dlgshow)
  (setq        dlgloaded t
        dlgshow        t
  )
  (if (null wz)
    (setq wz '(-1 -1))
  )
  (if (= -1 (setq rel (load_dialog dlgname)))
    (progn
      (princ (strcat "\n" dlgname "文件无法加载"))
      (setq dlgloaded nil
            rel        nil
      )
    )
  )
  (if (and dlgloaded (not (new_dialog dlg rel "" wz)))
    (progn
      (princ "\n无法显示该对话框")
      (setq dlgshow nil
            rel        nil
      )
    )
  )
  rel
)

(defun hb_txt_lstToStr (lst cha / rel)
  (setq rel "")
  (MAPCAR '(LAMBDA (itm) (setq rel (strcat rel itm cha)))
          lst
  )
  rel ;(setq rel (substr rel 1 (- (strlen rel) 1)))
)

(defun hb_txt_strToLst (str cha / rel n)
  (while (setq n (VL-STRING-SEARCH cha str))
    (setq rel (cons (substr str 1 n) rel)
          str (substr str (+ 2 n) (- (strlen str) n 1))
    )
  )
  (if (/= str "")
    (setq rel (cons str rel))
  )
  (REVERSE rel)
)

(defun hb_getSysTime (wei / n)
  (setq        rel (HB_XIAOSHU (getvar "cdate") 8)
        n   (VL-STRING-SEARCH "." rel)
        rel (substr rel (+ n 2) wei)
  )
)

(defun hb_isInRec (pt p0 p1 / xx xy dx dy)
  (if (< (car p0) (car p1))
    (setq xx (car p0)
          dx (car p1)
    )
    (setq xx (car p1)
          dx (car p0)
    )
  )
  (if (< (cadr p0) (cadr p1))
    (setq xy (cadr p0)
          dy (cadr p1)
    )
    (setq xy (cadr p1)
          dy (cadr p0)
    )
  )
  (and (<= xx (car pt) dx)
       (<= xy (cadr pt) dy)
  )
)

(defun hb_dxf_jieShiQi (dxfna / rel)
  (cond
    ((= dxfna "3DFACE") (SETQ REL "三维面"))
    ((= dxfna "3DSOLID") (SETQ REL "三维实体"))
    ((= dxfna "ARC") (SETQ REL "圆弧"))
    ((= dxfna "ATTDEF") (SETQ REL "属性定义"))
    ((= dxfna "ATTRIB") (SETQ REL "属性"))
    ((= dxfna "BODY") (SETQ REL "体"))
    ((= dxfna "CIRCLE") (SETQ REL "圆"))
    ((= dxfna "DIMENSION") (SETQ REL "标注"))
    ((= dxfna "ELLIPSE") (SETQ REL "椭圆"))
    ((= dxfna "HATCH") (SETQ REL "图案填充"))
    ((= dxfna "IMAGE") (SETQ REL "图像"))
    ((= dxfna "INSERT") (SETQ REL "插入（块参照）"))
    ((= dxfna "LEADER") (SETQ REL "引线"))
    ((= dxfna "LINE") (SETQ REL "直线"))
    ((= dxfna "LWPOLYLINE") (SETQ REL "优化多段线"))
    ((= dxfna "MLINE") (SETQ REL "多线"))
    ((= dxfna "MTEXT") (SETQ REL "多行文字"))
    ((= dxfna "POINT") (SETQ REL "点"))
    ((= dxfna "POLYLINE") (SETQ REL "多段线"))
    ((= dxfna "RAY") (SETQ REL "射线"))
    ((= dxfna "REGION") (SETQ REL "面域"))
    ((= dxfna "SHAPE") (SETQ REL "形"))
    ((= dxfna "SOLID") (SETQ REL "实体"))
    ((= dxfna "SPLINE") (SETQ REL "样条曲线"))
    ((= dxfna "TABLE") (SETQ REL "表"))
    ((= dxfna "TEXT") (SETQ REL "文字"))
    ((= dxfna "TOLERANCE") (SETQ REL "公差"))
    ((= dxfna "TRACE") (SETQ REL "跟踪"))
    ((= dxfna "VERTEX") (SETQ REL "顶点"))
    ((= dxfna "VIEWPORT") (SETQ REL "视口"))
    ((= dxfna "WIPEOUT") (SETQ REL "擦除"))
    ((= dxfna "XLINE") (SETQ REL "构造线"))
    (t (setq rel dxfan))
  )
)

;;;图层切换
(defun hb_layer_turn (ss tcna / n na ent laylst)
  (setq laylst (car tcna))
  (if (not (TBLSEARCH "layer" laylst))
    (hb_layer_build tcna)
  )
  (if ss
    (progn
      (setq n 0)
      (repeat (sslength ss)
        (setq na  (ssname ss n)
              ent (entget na)
        )
        (setq ent (subst (cons 8 laylst) (assoc 8 ent) ent))
        (if (and (= tc-color "Yes") (assoc 62 ent))
          (setq ent (subst (cons 62 256) (assoc 62 ent) ent))
        )
        (entmod ent)
        (setq n (+ n 1))
      )
    )
    (command "_.layer" "t" laylst "s" laylst "")
  )
)

;;;切换图层
(defun hb_turnLayer (layna / rel dy tmp na layob)
  (setq rel (getvar "CLAYER"))
  (if (null (TBLSEARCH "layer" layna))
    (progn
      (setq dy (MAPCAR 'cdr tc-lst))
      (if (null (setq tmp (assoc layna dy)))
        (setq tmp (list layna))
      )
      (HB_BUILD_LAYER tmp)
    )
  )
  (setq        na    (TBLOBJNAME "layer" layna)
        layob (vlax-ename->vla-object na)
  )
  (vla-put-layeron layob :vlax-true)
  (if (/= rel layna)
    (progn
      (vla-put-Freeze layob :vlax-false)
      (setvar "CLAYER" layna)
    )
  )
  rel
)




;;;新建图层
(defun hb_build_layer (lst / n newLay xar xdr nlst addlst)
  (if (null (TBLSEARCH "layer" (car lst)))
    (progn
      (setq newLay (entget (TBLOBJNAME "layer" "0"))
            newLay (subst (cons 2 (car lst)) (assoc 2 newLay) newLay)
            addlst '(6 "continuous" 62 7 70 0 290 1)
            nlst   (append addlst (cdr lst))
      )
      (setq n 0)
      (repeat (/ (length nlst) 2)
        (setq xar (nth (* 2 n) nlst)
              xdr (nth (1+ (* 2 n)) nlst)
        )
        (if (= xar 6)
          (hb_build_ltype xdr)
        )
        (setq newLay (subst (cons xar xdr) (assoc xar newLay) newLay)
              n             (1+ n)
        )
      )
      (entmake newLay)
    )
  )
)

;;;新建字体样式
(defun hb_build_style (sna font big / e3 e4 newzt rel)
  (if (null (TBLSEARCH "style" sna))
    (progn
      (if (findfile font)
        (setq e3 font
              e4 big
        )
        (if (findfile "hztxt.shx")
          (setq        e3 "hztxt.shx"
                e4 "hztxt.shx"
          )
          (setq        e3 "txt.shx"
                e4 "gbcbig.shx"
          )
        )
      )
      (setq newzt (entget (TBLOBJNAME "style" "standard"))
            newzt (HB_LIST_REPLACEENT
                    newzt
                    (list (cons 2 sna)
                          (cons 3 e3)
                          (cons 4 e4)
                    )
                  )
      )
      (setq rel (entmake newzt))
    )
    (setq rel t)
  )
)

;;;新建线型
(defun hb_build_ltype (ltna / found linetypeSel entry)
  (if (null (TBLSEARCH "ltype" ltna))
    (progn
      (setq found :vlax-false)
      (setq LinetypeSel (vla-get-Linetypes VLAXDOC))
;;;      (VLAX-FOR        entry LinetypeSel
;;;        (if (= (vla-get-Name entry) ltna)
;;;          (setq found :vlax-true)
;;;        )
;;;      )
;;;      (if (= found :vlax-false)
      (vla-load LinetypeSel ltna "acad.lin")
;;;      )
    )
  )
)




;;;判断目标是否符合列表的要求
(defun hb_naIsent (na lst / rel n itm tmp strlst ent tmp0 a1)
  (setq        rel t
        n   0
        ent (entget na)
  )
  (while (and rel
              (setq itm (nth n lst))
         )
    (setq tmp  (cdr itm)
          tmp0 (assoc (car itm) ent)
          n    (1+ n)
    )
    (if        tmp0
      (if (= (car itm) 0)
        (setq strlst (HB_TXT_STRTOLST tmp ",")
              a1     (cdr tmp0)
              rel    (apply 'or
                            (MAPCAR '(LAMBDA (x) (wcmatch a1 x))
                                    strlst
                            )
                     )
        )
        (setq rel (= (cdr tmp0) tmp))
      )
      (setq rel nil)
    )
  )
  rel
)


;;;增强型单选函数
(defun hb_entsel (msg lst init / e0 oldss rel is tmp)
  (if lst
    (progn
      (setq oldss (cadr (ssgetfirst)))
      (if (and oldss
               (= (sslength oldss) 1)
               (HB_NAISENT
                 (setq tmp (ssname oldss 0))
                 lst
               )
          )
        (setq rel tmp)
        (progn
          (sssetfirst nil nil)
          (while (null is)
            (initget init)
            (setq tmp (entsel msg))
            (cond
              ((= (type tmp) 'list)
               (if (HB_NAISENT (car tmp) lst)
                 (setq rel (car tmp)
                       is  t
                 )
                 (princ "请选择相关图元")
               )
              )
              ((= tmp "")
               (setq rel nil
                     is         t
               )
              )
              (tmp
               (setq is         t
                     rel tmp
               )
              )
            )
          )
          (setq is nil)
        )
      )
    )
    (while (null is)
      (initget "  ")
      (setq tmp (entsel))
      (cond
        ((= (type tmp) 'list)
         (setq rel (car tmp)
               is  t
         )
        )
        ((= tmp "")
         (setq rel nil
               is  t
         )
        )
      )
    )
  )
  rel
)

;;;获得在某物体后所创建的所有目标
(defun hb_get_entlast (ent / tmp rel)
  (setq        tmp ent
        rel (ssadd)
  )
  (while (setq tmp (entnext tmp))
    (ssadd tmp rel)
  )
  rel
)


(defun hb_getfirst (lst / slst ss na ent e0 rel)
  (setq        slst (ssgetfirst)
        ss   (cadr slst)
  )
  (if ss
    (if        (= (sslength ss) 1)
      (progn
        (setq na  (ssname ss 0)
              ent (entget na)
              e0  (cdr (assoc 0 ent))
        )
        (if (member e0 lst)
          (setq rel ss)
        )
      )
    )
  )
  rel
)

;;;获取比例
(defun hb_getDimBl (/ dim dna ent)
  (setq bl (getvar "dimscale"))
  (if (null bl)
    (progn
      (setq dim        (getvar "dimstyle")
            dna        (TBLOBJNAME "dimstyle" dim)
            ent        (entget dna)
            bl        (cdr (assoc 40 ent))
      )
    )
  )
  (cond
    ((null bl) 1.0)
    ((= bl 0) 1.0)
    (t bl)
  )
)

;;;移动视图到目标位置
(defun hb_ZoomE        (na / ss plst)
  (if na
    (progn
      (if (= (type na) 'ENAME)
        (progn
          (setq ss (ssadd))
          (ssadd na ss)
        )
        (setq ss na)
      )
      (setq plst (HB_GETBOX ss))
      (vl-cmdf "zoom"
               (trans (car plst) 0 1)
               (trans (cadr plst) 0 1)
      )
    )
  )
)
;;;获取目标的范围
(defun hb_getBox
                 (ss         /        rel    vlaxObj             minP   maxP
                  minExt maxExt        n      xx     xy     dx            dy
                  oldvar
                 )
  (setq n 0)
  (repeat (sslength ss)
    (setq vlaxObj (vlax-ename->vla-object (ssname ss n))
          minP          (vlax-make-variant)
          maxP          (vlax-make-variant)
          n          (1+ n)
    )
    (vla-GetBoundingBox vlaxObj 'minP 'maxP)
    (setq minExt (vlax-safearray->list minP)
          maxExt (vlax-safearray->list maxP)
    )
    (if        (= n 1)
      (setq xx (car minExt)
            xy (cadr minExt)
            dx (car maxExt)
            dy (cadr maxExt)
      )
      (progn
        (if (> xx (car minExt))
          (setq xx (car minExt))
        )
        (if (> xy (cadr minExt))
          (setq xy (cadr minExt))
        )
        (if (< dx (car maxExt))
          (setq dx (car maxExt))
        )
        (if (< dy (cadr maxExt))
          (setq dy (cadr maxExt))
        )
      )
    )
  )
  (list (list xx xy) (list dx dy))
)

;;;更新保存或加载坐标系
(defun hb_ucsNew (lst is / yd ang)
  (if is
    (progn
      (setq yd        (getvar "UCSORG")
            ang        (HB_UCSANG)
      )
      (vl-cmdf "_.UCS" "N" (trans (car lst) 0 1))
      (vl-cmdf "_.UCS"
               "Z"
               (HB_HUTODU (- (angle (car lst) (cadr lst)) (HB_UCSANG)))
      )
      (list yd ang)
    )
    (progn
      (setq yd        (car lst)
            ang        (cadr lst)
      )
      (vl-cmdf "_.UCS" "N" (trans yd 0 1))
      (vl-cmdf "_.UCS" "Z" (HB_HUTODU (- ang (HB_UCSANG))))
    )
  )
)




(defun hb_getNaBox (na / vlaxobj minp maxp minExt maxExt)
  (setq        vlaxObj        (vlax-ename->vla-object na)
        minP        (vlax-make-variant)
        maxP        (vlax-make-variant)
  )
  (vla-GetBoundingBox vlaxObj 'minP 'maxP)
  (setq        minExt (vlax-safearray->list minP)
        maxExt (vlax-safearray->list maxP)
  )
  (list minExt maxExt)
)

;;;读取注册表某个数据
(defun hb_reg_readOne (weizi ming def / rel lst)
  (setq lst (hb_reg (list (cons ming def)) weizi t))
  (cdr (assoc ming lst))
)

;;;写入注册表某个数据
(defun hb_reg_writeOne (weizi ming val / )
  (hb_reg (list (cons ming val)) weizi nil)
)
[/PHP]

下面是该程序代码，请先加载上面的函数库再加载下面的文件。
[PHP]

(setq tc-lst (list
           '("s1" "y-设计-01" 62 7 6 "Continuous" 290 1) '("s2" "y-设计-02" 62 4 6 "Continuous" 290 1)
           '("s3" "y-设计-03" 62 6 6 "Continuous" 290 1) '("t1" "y-填充-01" 62 2 6 "Continuous" 290 1)
           '("t2" "y-填充-02" 62 251 6 "Continuous" 290 1) '("c1" "y-尺寸" 62 7 6 "Continuous" 290 1)
           '("fg" "y-铺装分隔" 62 8 6 "Continuous" 290 1) '("qt" "y-其它" 62 3 6 "Continuous" 290 1)
           '("ss" "y-设施" 62 5 6 "Continuous" 290 1) '("sx" "y-竖向" 62 7 6 "Continuous" 290 1)
           '("sy" "y-索引" 62 7 6 "Continuous" 290 1) '("wg" "y-网格" 62 1 6 "Continuous" 290 1)
           '("wz" "y-文字" 62 2 6 "Continuous" 290 1) '("yc" "y-隐藏线" 62 251 6 "HIDDEN" 290 1)
           '("z1" "y-植物" 62 94 6 "Continuous" 290 1) '("vw" "view" 62 6 6 "Continuous" 290 0)
           '("tmp" "temp" 62 1 6 "Continuous" 290 0))
)

(setq tc_dybFile "")


(defun tc-bianTC (tcna / n na ent laylst layob blst sss)
  (HB_START (list (cons "cmdecho" 0)) t)
  (if t
    (if    tcna
      (progn
    (prompt (strcat "\n>>>图层转换到: " (car tcna) "..."))
    (setq sss (ssget))
    (setq laylst (car tcna))
    (if (not (TBLSEARCH "layer" laylst))
      (tc-buildLayer tcna)
    )
    (if sss
      (progn
        (setq n 0)
        (repeat (sslength sss)
          (setq na    (ssname sss n)
            ent    (entget na)
          )
          (setq ent (subst (cons 8 laylst) (assoc 8 ent) ent))
          (if (and (= tc-color "Yes") (assoc 62 ent))
        (setq ent (subst (cons 62 256) (assoc 62 ent) ent))
          )
          (entmod ent)
          (setq n (+ n 1))
        )
      )
      (if (/= (getvar "clayer") laylst)
        (progn
          (setq na      (TBLOBJNAME "layer" laylst)
            layob (vlax-ename->vla-object na)
          )
          (vla-put-Freeze layob :vlax-false)
          (setvar "CLAYER" laylst)
        )
      )
    )
      )
      (princ "\n未知的命令!")
    )
  )
  (HB_START nil nil)
)


(defun tc-buildLayer (lst / n newLay xar xdr nlst)
  (setq    newLay (entget (TBLOBJNAME "layer" "0"))
    newLay (subst (cons 2 (car lst)) (assoc 2 newLay) newLay)
    nlst   (cdr lst)
  )
  (setq n 0)
  (repeat (/ (length nlst) 2)
    (setq xar (nth (* 2 n) nlst)
      xdr (nth (1+ (* 2 n)) nlst)
    )
    (if    (= xar 6)
      (tc-buildLtype xdr)
    )
    (setq newLay (subst (cons xar xdr) (assoc xar newLay) newLay)
      n     (1+ n)
    )
  )
  (entmake newLay)
)

(defun c:tc-color (/ tmp)
  (initget "Yes No")
  (setq    tmp (getkword
          (strcat "\n修改目标图层时，是否将目标颜色设置为随层?<"
              tc-color
              ">"
          )
        )
  )
  (if tmp
    (setq tc-color tmp)
  )
)

(defun tc-buildLtype (ltna / linetypeSel)
  (setq LinetypeSel (vla-get-Linetypes VLAXDOC))
  (if (null (TBLSEARCH "ltype" ltna))
    (vla-load LinetypeSel ltna "acad.lin")
  )
)

(defun c:tcset (/ itm n str tmp n dcl_id blst strlst tmplst)
  (setq    tmplst tc-lst
    blst   (TC-LSTTOBSTR tmplst)    ;转换成能使注册表使用的列表
    blst   (HB_REG blst "tuChengSet" t) ;获得注册表对应值
    tc-lst (TC-BSTRTOLST blst)    ;返回给对应表
    tmplst tc-lst
    strlst (TC-BSTRTOSTR blst)    ;获得全文字列表
  )
  (if (setq dcl_id (HB_DLG_START "tc_dlg.dcl" "tcdlg" nil))
    (progn
      (HB_DLG_LISTADD "tc_dyb" strlst)
      (action_tile "tc_tj" "(tc-dlgTj)")
      (action_tile "tc_sc" "(tc-dlgSc)")
      (action_tile "tc_bj" "(tc-dlgEdit)")
      (action_tile "tc_bc" "(tc-dlgSave)")
      (action_tile "tc_jz" "(tc-dlgLoad)")
      (action_tile "cancel" "(setq ok nil)(DONE_DIALOG)")
      (action_tile "accept" "(setq ok t)(DONE_DIALOG)")
      (START_DIALOG)
      (UNLOAD_DIALOG dcl_id)
      (if ok
    (progn
      (setq    blst   (TC-STRTOBSTR strlst)
        tc-lst tmplst
      )
      (HB_REGDEL nil "tuChengSet")
      (hb_reg blst "tuChengSet" nil)
      (setq m_lst (MAPCAR 'cdr tc-lst))
      (TC-LOADTCCOMMAND)
    )
      )
    )
  )
  (princ)
)




;;;从完全列表转换成半列表
(defun tc-lstToBStr (lst / itm n str tmp rel)
  (foreach itm lst
    (setq n   2
      str (nth 1 itm)
    )
    (while (setq tmp (nth n itm))
      (if (= (type tmp) 'INT)
    (setq tmp (itoa tmp))
      )
      (setq str    (strcat str "," tmp)
        n    (1+ n)
      )
    )
    (setq rel (cons (cons (nth 0 itm) str) rel))
  )
  (REVERSE rel)
)

;;;从半列表转换成全文本列表
(defun tc-bStrToStr (lst / x)
  (MAPCAR '(LAMBDA (x)
         (strcat (car x) "=" (cdr x))
       )
      lst
  )
)

;;;从全文本列表转换成半列表
(defun tc-strTobStr (lst / x tmp)
  (mapcar '(lambda (x)
         (setq tmp (HB_STRING_BYCHAR x "="))
         (cons (car tmp) (cadr tmp))
       )
      lst
  )
)

;;;从半列表转换成全列表
(defun tc-bstrToLst (lst / itm tmp strlst rel)
  (foreach itm lst
    (setq tmp     (car itm)
      strlst (HB_TXT_STRTOLST (cdr itm) ",")
      strlst (MAPCAR '(LAMBDA (x)
                (if    (TC-STRISINT x)
                  (atoi x)
                  x
                )
              )
             strlst
         )
      tmp     (append (list tmp) strlst)
    )
    (setq rel (cons tmp rel))
  )
  (REVERSE rel)
)


;;;判断某文本值是否为整数
(defun tc-strIsInt (str / n len rel tmp)
  (setq    n   1
    len (strlen str)
    rel t
  )
  (while (and (<= n len)
          rel
     )
    (setq tmp (substr str n 1))
    (if    (null (VL-STRING-SEARCH tmp "0123456789"))
      (setq rel nil)
    )
    (setq n (1+ n))
  )
  rel
)

(defun tc-dlgSave (/ fpath file x)
  (if (setq fpath (getfiled "文件保存为" "图层快捷键表" "tcb" 1))
    (if    (setq file (open fpath "w"))
      (progn
    (MAPCAR '(LAMBDA (x) (write-line x file)) strlst)
    (close file)
    (setq tc_dybfile fpath)
      )
    )
  )
)

(defun tc-dlgLoad (/ fpath tmp)
  (if (setq fpath (getfiled "打开图层快捷键表" tc_dybfile "tcb" 0))
    (if    (setq tmp (HB_GETFILEDATE fpath))
      (progn
    (setq strlst tmp
          blst   (TC-STRTOBSTR strlst)
          tmplst (TC-BSTRTOLST blst)
    )
    (HB_DLG_LISTADD "tc_dyb" strlst)
      )
    )
  )
)

(defun tc-dlgTj    (/ at lst jm n mc tmp end m)
  (setq    at  (atoi (get_tile "tc_dyb"))
    lst (nth at tmplst)
    jm  (car lst)
    n   1
  )
  (setq end(substr jm (strlen jm) 1))
  (if (setq m (VL-STRING-SEARCH end "0123456789"))
    (setq n  m
      jm (substr jm 1 (- (strlen jm) 1))
    )
  )
  (while (null mc)
    (setq tmp (strcat jm (itoa n)))
    (if    (tc-findJm tmp)
      (setq n (1+ n))
      (setq mc tmp)
    )
  )
  (setq    lst(HB_LIST_REPLACEAT lst mc 0))
  (TC-DLGEDITADD lst)
)

(defun tc-dlgEditAdd (lst    / jian    name   color  lin    pnt
           ok      dcl_id nlin    nlay   tclst  linlst at len
          )
  (setq    jian  (nth 0 lst)
    name  (nth 1 lst)
    color (nth 3 lst)
    lin   (nth 5 lst)
    pnt   (nth 7 lst)
  )
  (setq    tclst  (HB_TABLELIST "layer" t)
    linlst (HB_TABLELIST "ltype" t)
  )
  (if (setq dcl_id (HB_DLG_START "tc_dlg.dcl" "tcedit" nil))
    (progn
      (set_tile "tcedit_kjj" jian)
      (set_tile "tcedit_yswz" (itoa color))
      (set_tile "tcedit_mc" name)
      (set_tile "tcedit_dy" (itoa pnt))
      (HB_DLG_IMAGE "tcedit_ys" color nil)
      (if (null (setq n (hb_list_at lin linlst)))
    (setq linlst (cons lin linlst)
          n         0
    )
      )
      (if (null (TBLSEARCH "layer" name))
    (setq tclst (cons name tclst))
      )
      (HB_DLG_LISTADD "tcedit_tclb" tclst)
      (HB_DLG_LISTADD "tcedit_xx" linlst)
      (set_tile "tcedit_xx" (itoa n))
      (action_tile "tcedit_tclb" "(tc-editdlg-tclb)")
      (action_tile "tcedit_ys" "(tc-editdlg-ys)")
      (action_tile "tcedit_dy" "(tc-editdlg-dy)")
      (action_tile "tcedit_xx" "(tc-editdlg-xx)")
      (action_tile "cancel" "(setq ok nil)(DONE_DIALOG)")
      (action_tile
    "accept"
    "(tc-editdlg-accept nil)"
      )
      (START_DIALOG)
      (UNLOAD_DIALOG dcl_id)
    )
  )
  (if ok
    (progn
      (setq lst       (list jian name 62 color 6 lin 290 pnt)
        tmplst (append tmplst (list lst))
        blst   (TC-LSTTOBSTR tmplst)
        strlst (TC-BSTRTOSTR blst)
        len (length tmplst)
      )
      (start_list "tc_dyb" 2)
      (add_list (nth (- len 1) strlst))
      (end_list)
      (set_tile "tc_dyb" (itoa (- len 1)))
      tmplst
    )
    nil
  )
)

(defun tc-dlgSc    (/ at)
  (setq    at     (atoi (get_tile "tc_dyb"))
    oldcom (car (nth at tmplst))
    tmplst (HB_LIST_DELAT tmplst at)
    blst   (TC-LSTTOBSTR tmplst)
    STRLST (TC-BSTRTOSTR blst)
  )
  (HB_DLG_LISTADD "tc_dyb" strlst)
  (set_tile "tc_dyb" (itoa at))
)

(defun tc-findJm (str / n rel)
  (setq n 0)
  (while (and (< n (length tmplst))
          (null rel)
     )
    (if    (= str (car (nth n tmplst)))
      (setq rel (nth n tmplst))
    )
    (setq n (1+ n))
  )
  rel
)

(defun tc-dlgEdit (/      lst     jian    name   color  lin    pnt
           ok      dcl_id nlin    nlay   tclst  linlst at oldj
          )
  (setq    at     (atoi (get_tile "tc_dyb"))
    lst    (nth at tmplst)
  )
  (setq    jian  (nth 0 lst)
           oldj jian
    name  (nth 1 lst)
    color (nth 3 lst)
    lin   (nth 5 lst)
    pnt   (nth 7 lst)
  )
  (setq    tclst  (HB_TABLELIST "layer" t)
    linlst (HB_TABLELIST "ltype" t)
  )
  (if (setq dcl_id (HB_DLG_START "tc_dlg.dcl" "tcedit" nil))
    (progn
      (set_tile "tcedit_kjj" jian)
      (set_tile "tcedit_yswz" (itoa color))
      (set_tile "tcedit_mc" name)
      (set_tile "tcedit_dy" (itoa pnt))
      (HB_DLG_IMAGE "tcedit_ys" color nil)
      (if (null (setq n (hb_list_at lin linlst)))
    (setq linlst (cons lin linlst)
          n         0
    )
      )
      (if (null (TBLSEARCH "layer" name))
    (setq tclst (cons name tclst))
      )
      (HB_DLG_LISTADD "tcedit_tclb" tclst)
      (HB_DLG_LISTADD "tcedit_xx" linlst)
      (set_tile "tcedit_xx" (itoa n))
      (action_tile "tcedit_tclb" "(tc-editdlg-tclb)")
      (action_tile "tcedit_ys" "(tc-editdlg-ys)")
      (action_tile "tcedit_dy" "(tc-editdlg-dy)")
      (action_tile "tcedit_xx" "(tc-editdlg-xx)")
      (action_tile "cancel" "(setq ok nil)(DONE_DIALOG)")
      (action_tile
    "accept"
    "(tc-editdlg-accept oldj)"
      )
      (START_DIALOG)
      (UNLOAD_DIALOG dcl_id)
    )
  )
  (if ok
    (progn
      (setq lst       (list jian name 62 color 6 lin 290 pnt)
        tmplst (HB_LIST_REPLACEAT tmplst lst at)
        blst   (TC-LSTTOBSTR tmplst)
        strlst (TC-BSTRTOSTR blst)
      )
      (start_list "tc_dyb" 1 at)
      (add_list (nth at strlst))
      (end_list)
      (set_tile "tc_dyb" (itoa at))
      tmplst
    )
    nil
  )
)




(defun tc-editdlg-tclb (/ n)
  (setq    n    (get_tile "tcedit_tclb")
    name (nth (atoi n) tclst)
  )
  (set_tile "tcedit_mc" name)
)


(defun tc-editdlg-ys (/ tmp)
  (if (setq tmp (ACAD_COLORDLG color))
    (progn
      (setq color tmp)
      (HB_DLG_IMAGE "tcedit_ys" color nil)
      (set_tile "tcedit_yswz" (itoa color))
    )
  )
)

(defun tc-editdlg-dy (/)
  (if (= pnt 0)
    (setq pnt 1)
    (setq pnt 0)
  )
)

(defun tc-editdlg-accept (oldna /)
  (setq    name (get_tile "tcedit_mc")
    jian (get_tile "tcedit_kjj")
  )
  (cond
    ((and (null oldna)
          (TC-FINDJM jian)
     )
     (ALERT
       (strcat "\"" jian "\" 此快捷键已经存在，请使用其它快捷键！")
     )
     (mode_tile "tcedit_kjj" 2)
    )
    ((= jian "")
     (ALERT "快捷键名不能为空")
     (mode_tile "tcedit_kjj" 2)
    )
    ((and (/= jian oldna)
          (TC-FINDJM jian)
     )
     (ALERT
       (strcat "\"" jian "\" 此快捷键已经存在，请使用其它快捷键！")
     )
     (mode_tile "tcedit_kjj" 2)
    )
    (t
     (setq ok t)
     (done_dialog)
    )
  )
)

(defun tc-editdlg-xx (/ n)
  (setq    n   (get_tile "tcedit_xx")
    lin (nth (atoi n) linlst)
  )
)

(defun tc-autoSet (/ blst)
  (setq    tc-color "Yes"
    m_lst     (MAPCAR 'cdr tc-lst)
    blst     (TC-LSTTOBSTR tc-lst)    ;转换成能使注册表使用的列表
    blst     (HB_REG blst "tuChengSet" t) ;获得注册表对应值
    tc-lst     (TC-BSTRTOLST blst)    ;返回给对应表
  )
  (tc-loadTcCommand)
)

;;;实时加载快捷键文件
(defun tc-loadTcCommand    (/ path fna file)
  (setq    path (HB_GET_SUPDIR)
    fna  (strcat path "hb_forLayerSet.lsp")
  )
  (if (setq file (open fna "w"))
    (progn
      (MAPCAR 'tc-addCommand tc-lst)
      (close file)
    )
  )
  (if (findfile fna)
    (VL-LOAD-ALL fna)
  )
)

(defun tc-addCommand (str / ml txt itm)
  (setq    ml  (car str)
    txt (list (strcat "(defun c:" ml "()")
          (strcat "(tc-bianTC (cdr (assoc \"" ml "\" tc-lst)))")
          "(princ)"
          ")"
          ""
        )
  )
  (foreach itm txt
    (write-line itm file)
  )
)

(TC-AUTOSET)

[/PHP]

下面是对话框文件，请存为"tc_dlg.dcl"
[PHP]
tcdlg:dialog{
  label="快捷键与图层对应表";
  :spacer{height=0.2;}
  :column{
    label="对应表操作";
    :row{
      :list_box{
        key="tc_dyb";
        width=50;
        height=15;
        }
      :spacer{height=0.2;}
      }
      :row{
        :button{
          label="添加";
          key="tc_tj";
          }
        :button{
          label="删除";
          key="tc_sc";
          }
        :button{
          label="编辑";
          key="tc_bj";
          }
        :button{
          label="保存";
          key="tc_bc";
          }
        :button{
          label="加载";
          key="tc_jz";
          }
        }
      }
      :spacer{height=0.2;}
      :row{
        :spacer{width=15;}
        ok_cancel;
      }
  }


tcedit:dialog{
  label="对应图层设置";
  :spacer{height=0.1;}
  :row{
    :edit_box{
      label="快捷键";
      key="tcedit_kjj";
     // fixed_width=true;
    }
    :spacer{width=12;}
  }
  :spacer{height=0.1;}
  :column{
  :row{
    :text{label="层名   ";}
    :edit_box{
      key="tcedit_mc";
      width=15;
      }
    :popup_list{
      key="tcedit_tclb";
      }
    }
    :spacer{height=0.1;}
  :row{
    :text{label="颜色   ";}
    :image_button{
      key="tcedit_ys";
      width=4;
      height=2;
      fixed_width=true;
      fixed_height=true;
      }
    :text{
      label="白色";
      key="tcedit_yswz";
      }
    :spacer{width=15;}
    }
  :row{
    :text{label="线型   ";}
    :popup_list{
      key="tcedit_xx";
      width=16;
      }
    :spacer{width=10;}
    }
  :spacer{height=0.1;}
  :toggle{
    label="可打印该图层";
    key="tcedit_dy";
    }
  :spacer{height=0.1;}
  }
  :spacer{height=0.1;}
  ok_cancel;
  }
[/pcode]

twtwvl

看起来是一个不错的东东

wei209

强啊，呵呵！

flcwk

十分有用啊，找了好久了！
谢谢lz的无私奉献。

slary2002

不会用，

xinr111

我觉得这个搞的有点麻烦.