[LISP程序]：设备表内容锁定开

crtrccrt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                          ;;
;;  程序名称: 设备表内容锁定开关                                            ;;
;;  文件名称: C-Snrsd.lsp                                                   ;;
;;  程序功能: 设备表内容锁定开关                                            ;;
;;  设    计:                                完成日期:                      ;;
;;  编程调试:                                完成日期:                      ;;
;;  程序修改: 范建新                         完成日期:   1999.11.10         ;;
;;  程序测试: 段  云                         完成日期:   1999.11.20         ;;
;;  版本序号: InterDQ V3.0                                                  ;;
;;  版权所有: 北京浩辰技术开发公司                                          ;;
;;                                                                          ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;=================================主函数开始=================================
;;名称：snrsd
;;功能：设备表内容锁定开关
;;输入：lay
;;返回：无
(defun snrsd (lay /  a col ent ents entx errn i loop pand pm1 pm2 pnt1 pnt2 pt
                     pt1 pt2 pt3 pt4 ssl sstext s_enls s_enlx s_zoom)
  (setq errold *error*)
  
;;================================子函数开始==================================
;;名称：*error*(错误处理函数)
;;功能：当程序发生错误或用户中断时，平静地退出，并还原状态。
;;输入：无
;;返回：无
(defun *error* (msg / eachxx)
  (foreach eachxx '( a col ent ents entx errn i loop pand pm1 pm2 pnt1 pnt2 pt
                     pt1 pt2 pt3 pt4 ssl sstext s_enls s_enlx s_zoom l ll pnt1x
                     pnt2x ptx pty lay snrsd)
    (set eachxx nil)
  )
  (setq *error* errold errold nil)
  (_resdwg)
  (princ)
)

;;================================子函数开始==================================
;;名称：s_enls
;;功能：离点上方最近的水平直线
;;输入：pt-点 ssl-选择集
;;返回：ent
  (defun s_enls(pt ssl / ent i l ll pnt1 pnt1x pnt2 pnt2x ptx pty)
    (setq i 0 l nil ptx(car pt) pty(cadr pt))
    (repeat (sslength ssl)
      (setq pnt1 (cdr (assoc 10 (entget (ssname ssl i))))
            pnt2 (cdr (assoc 11 (entget (ssname ssl i))))
      )
      (if(equal(cadr pnt1)(cadr pnt2) 0.1)
        (progn
          (setq pnt1x(car pnt1) pnt2x(car pnt2))
          (if(and(> ptx (min pnt1x pnt2x))(< ptx (max pnt1x pnt2x))(<= pty (cadr pnt1)))
            (progn
              (if(not l)(setq l(-(cadr pnt1)pty)))
              (setq ll(-(cadr pnt1)pty))
              (if(<= ll l)(setq l ll ent (ssname ssl i)))
            )
          )
        )
      )
      (setq i (1+ i))
    )
    (if(not ent)(progn(Xacino "选在了设备表外!" "操作错误" 6)(setq ent nil)))
    ent
  )

;;================================子函数开始==================================
;;名称：s_enlx
;;功能：离点下方最近的水平直线
;;输入：pt-点 ssl-选择集
;;返回：ent
  (defun s_enlx(pt ssl / ent i l ll pnt1 pnt1x pnt2 pnt2x ptx pty)
    (setq i 0 l nil ptx(car pt) pty(cadr pt))
    (repeat (sslength ssl)
      (setq pnt1 (cdr (assoc 10 (entget (ssname ssl i))))
            pnt2 (cdr (assoc 11 (entget (ssname ssl i))))
      )
      (if(equal(cadr pnt1)(cadr pnt2) 0.1)
        (progn
          (setq pnt1x(car pnt1) pnt2x(car pnt2))
          (if(and(> ptx (min pnt1x pnt2x))(< ptx (max pnt1x pnt2x))(>= pty (cadr pnt1)))
            (progn
              (if(not l)(setq l(- pty (cadr pnt1))))
              (setq ll(- pty (cadr pnt1)))
              (if(<= ll l)(setq l ll ent (ssname ssl i)))
            )
          )
        )
      )
      (setq i (1+ i))
    )
    (if(not ent)(progn(Xacino "选在了设备表外!" "操作错误" 6)(setq ent nil)))
    ent
  )
  
;;================================子函数开始==================================
;;名称：s_zoom
;;功能：设备表在当前屏幕外时ZOOM
;;输入：pm1 pm2(屏幕的左下角点和右上角点)pnt1 pnt1(所选设备表栏左下角点和右上角点)
;;返回：pand-如果ZOOM了返回t,否则返回nil
  (defun s_zoom(pm1 pm2 pnt1 pnt2 / pand)
    (if(or(>(car pm1)(car pnt1))(>(cadr pm1)(cadr pnt1))(<(car pm2)(car pnt2))(<(cadr pm2)(cadr pnt2)))
      (progn(command "_.zoom" pnt1 pnt2)(setq pand t))
      (setq pand nil)
    )
    pand
  )
  
;;================================子函数结束==================================
  (_inidwg)
  (setvar "cmdecho" 0)
  (setvar "blipmode" 0)
  (command "_.graphscr")
  (setvar "osmode" 0)
  (setq loop t)
  (while loop
    (setq a(XEntSl "\n请点取需锁定或解锁的设备表内容<回车结束>:"(list(cons 8 lay)(cons 0 "TEXT"))))
    (setq errn (getvar "errno"))
    (cond
      ((and (/= a nil) (listp a))
       (setq pt(last a) pm1(car (Xscjx)) pm2(cadr (Xscjx)))
       (setq ssl(ssget "X" (list(cons 8 lay)(cons 0 "LINE"))))
       (if ssl
         (progn
           (setq ents (s_enls pt ssl))
           (if ents (setq entx (s_enlx pt ssl)))
           (if entx
             (progn
               (setq pt1 (cdr (assoc 10 (entget entx)))
                     pt2 (cdr (assoc 11 (entget entx)))
                     pt3 (cdr (assoc 10 (entget ents)))
                     pt4 (cdr (assoc 11 (entget ents)))
               )
               (if(equal(abs(-(car pt1)(car pt2)))(abs(-(car pt3)(car pt4)))1.0)
                 (progn
                   (if(<(car pt1)(car pt2))(setq pnt1 pt1)(setq pnt1 pt2))
                   (if(<(car pt3)(car pt4))(setq pnt2 pt4)(setq pnt2 pt3))
                   (setq pand(s_zoom pm1 pm2 pnt1 pnt2))
                   (setq col(cdr(assoc 62(entget(car a)))))
                   (if(= col 1)(setq col 3)(setq col 1))
                   (setq i 0 sstext(ssget "C" pnt1 pnt2(list(cons 8 lay)(cons 0 "TEXT"))))
                   (repeat (sslength sstext)
                     (setq ent (ssname sstext i))
                     (command "_.change" ent "" "_p" "_c" (rtos col 2 0) "")
                     (setq i (1+ i))
                   )
                   (if pand(command "_.zoom" pm1 pm2))
                 )
                 (Xacino "当前图中设备表重叠!" "注意" 6)
               )
             )
           )
         )
         (Xacino "当前图中没有设备表!" "操作错误" 6)
       )
      )
      ((= errn 52) (setq loop nil))
    )
  )
  (setvar "highlight" 1)
  (setq *error* errold errold nil)
  (_resdwg)
  (princ)
)

qjcpj

请楼主简单说明一下程序的功能和用途！

啵浪鼓

楼主的程序还没有上传完吧？？？

(_resdwg)