[编程申请]：求CAD2007版本中均匀布置图块的lsp

jadekylin

我们在做照明设计的过程中，特别是在做厂房设计的情况，经常需要均匀布置灯，天正电气里倒是可以实现，哪位大虾能否帮小弟编写一个有如此功能的lsp，多谢！
我这里倒是有两个程序：lplace.lsp,undo.lsp，可以在R14里用，要同时加载，但是不能在2007里用，可否帮我看看，改一下，多谢！
lplace.lsp[/COLOR]
;----------------------------------------------------------------------------
;  GLOBALS:
;     light_layer -- layer of light
;     wire_layer  -- layer of wire
;----------------------------------------------------------------------------
(defun lplace(/ m n insblk insang inspt olyr)
  (if (and (not undo_init) (equal -1 (load "undo.lsp" -1)))
      (progn (alert "Error:\n   Cannot find UNDO.LSP.") (exit))
  );if
  (err_init '("CMDECHO" "OSMODE" "BLIPMODE" "REGENMODE") T '(setq l_s nil))
  (var_set '(("CMDECHO" 0) ("OSMODE" 0) ("BLIPMODE" 0) ("REGENMODE" 0)))
  
  ;; Get information
  
  (cond ((numberp light_scale)) (T (setq light_scale 1)))
  (cond (light_layer) (T (setq light_layer (getvar "CLAYER"))))
        
  (prompt (strcat "\n默认图层：\"" light_layer "\"。" ))
  (prompt (strcat "\n默认比例：\"" (rtos light_scale 2 2) "\"。"))
  (cond
    ((= (cdar (laychk light_layer)) "No")
      (laychk (setq light_layer (getvar "CLAYER")))
      (prompt (strcat "\n图层被设为当前层：\"" light_layer "\"。" ))
    )
  ); cond
   
  (while (not insblk)
    (initget "Layer Scale Name")
    (setq insblk (getkword "\n图层 L / 比例 S / 图块名 N："))
    (cond
      ((= "Scale" insblk)
       (initget 6)
       (setq light_scale
         (cond ((getreal (strcat "\n请输入图块比例：<"
                                (rtos light_scale 2 2)
                                "> ")))
               (T light_scale)
         ); cond
         insblk nil
       ); setq
      )
      ((= "Layer" insblk)
       (setq olyr light_layer insblk nil)
       (setq light_layer (getstring (strcat "\n请选择图层：<"
                                            light_layer "> ")))
       (cond ((= light_layer "") (setq light_layer olyr)))
       (cond ((= (cdar (laychk light_layer )) "No")
              (setq light_layer olyr)
              (prompt (strcat "\n图层仍为：\"" light_layer "\"。" )))
       ); cond
      )
      (T
       (cond
         ((= (getvar "INSNAME") "")
           (setq insblk (getstring "\n请输入图块名："))
           (cond ((tblsearch "BLOCK" insblk) (setvar "INSNAME" insblk))
                 (T (setq insblk nil))); cond
         )
         (T
           (setq insblk (getstring (strcat "\n请输入图块名：<"
                                            (getvar "INSNAME") "> ")))
           (cond ((= insblk "") (setq insblk (getvar "INSNAME")))); cond
           (cond ((tblsearch "BLOCK" insblk) (setvar "INSNAME" insblk))
                 (T (setq insblk nil))); cond
         )
       ); cond
       (cond (insblk) (T (prompt "\n无效的图块！"))); cond
      )
    ); cond
  ); while      
  
  (setq insang (getangle "\n请输入图块的角度：<0> "))
  (cond ((not insang) (setq insang 0)))
  (setq inspt (gettrs))
  
  (setq n 0)  
  (while (< n (length inspt))
    (setq m 0)
    (while (< m (length (car inspt)))
      (apply '(lambda (iname ilayer ipoint iscale iangle)
                (entmake (list (cons 0 "INSERT")
                               (cons 2 iname)
                               (cons 8 ilayer)
                               (cons 10 ipoint)
                               (cons 41 iscale)
                               (cons 42 iscale)
                               (cons 43 iscale)
                               (cons 50 iangle)
                         )
                ); entmake
              ); lambda
             (list insblk light_layer (nth m (nth n inspt)) light_scale insang)   
       ); apply
      (setq m (1+ m))
    ); while
    (setq n (1+ n))
  ); while
  
  (initget 1 "Yes No")
  (cond ((= "Yes" (getkword "\n是否需要连线 ？(Y/N) "))
         (connect insblk insang light_scale inspt))
  ); cond

  (layres)
  (err_restore)
  (princ)
); defun lplace

(defun gettrs(/ ulpt lrpt row col inspt deltax deltay n)
  (initget 1)
  (setq ulpt (getpoint "\n请选择右上角："))
  (initget 1)      
  (setq lrpt (getcorner ulpt "\n请选择左下角："))
  (grdraw ulpt (list (nth 0 lrpt) (nth 1 ulpt)) 2 1)
  (grdraw (list (nth 0 lrpt) (nth 1 ulpt)) lrpt 2 1)
  (grdraw lrpt (list (nth 0 ulpt) (nth 1 lrpt)) 2 1)
  (grdraw (list (nth 0 ulpt) (nth 1 lrpt)) ulpt 2 1)

  (initget 7)
  (setq row (getint "\n请输入行数："))
  (initget 7)
  (setq col (getint "\n请输入列数："))
  (setq deltax (/ (- (car lrpt) (car ulpt)) col)
        deltay (/ (- (cadr ulpt) (cadr lrpt)) row)
  ); setq

  ;; Try to find the transformer of points
  
  (repeat col
  ;  new_first_row = (cons ((old_point) - deltax) old_first_row
    (cond (inspt
            ((lambda (x)
             (setq inspt (subst (cons (list (- (nth 0 (car x)) deltax)
                                            (nth 1 (car x))
                                            (nth 2 (car x))) x)
                                 x
                                inspt))
             ); lambda
             (car inspt))
          )
          (T
             (setq inspt (list (list (list (- (nth 0 lrpt) (/ deltax 2.0))
                                           (- (nth 1 ulpt) (/ deltay 2.0))
                                           (nth 2 ulpt))))); setq
          )
    ); cond
  
    (setq n 0)
    (while (< n (1- row))
    ;  new_row_information = (cons new_list old_row_information)
    ;                        or (subst new_row_information old_row_information)
    ;  new_list = (car old_row_information) - deltay
   
      (apply
        '(lambda (x y)
           (cond ( y
                   (setq inspt (subst (cons (list (nth 0 (car x))
                                                  (- (nth 1 (car x)) deltay)
                                                  (nth 2 (car x))) y)
                                      y
                                      inspt))
                 )
                 (T (setq inspt (append inspt (list (cons (list (nth 0 (car x))
                                                                (- (nth 1 (car x)) deltay)
                                                                (nth 2 (car x)) ) y))))
                 )
           ); cond
         ); lambda
         (list (nth n inspt) (nth (1+ n) inspt))
      )
      (setq n (1+ n))
    ); while  
  ); repeat
  inspt
); defun gettrs

(defun turntrs(otrs / ntrs m n)
  (setq n 0)
  (while (< n (length otrs))
    ((lambda (x)
      (setq m (1- (length x)))
      (while (>= m 0)
        (cond
          (ntrs
            ((lambda (y)
              (if y
                (setq ntrs (subst (cons (nth m x) y)
                                  y
                                  ntrs))
                (setq ntrs (append ntrs (list (cons (nth m x) y))))
              ); if
             ); lambda
             (nth (- (length x) m 1) ntrs)      ; new row information
            )
          )
          (T (setq ntrs (list (list (nth m x)))))
        ); cond
        (setq m (1- m))
      ); while
     ); lambda
     (nth n otrs)
    )
    (setq n (1+ n))
  ); while
  ntrs
); defun turntrs

(defun connect(insblk insang inscale inspt / fp blkinf flag temp ppair hor m n offset )  
  ; fetch available information of blocks
  ((lambda (f)
     (cond
       (f
         (setq fp (open f "r") temp (read-line fp))
         (while (and temp (not blkinf))
           ((lambda(x)
              (if (and (listp x) x)
                (if (= (strcase (cdr (assoc 0 x))) (strcase insblk))
                    (setq blkinf x))
              ); if
            ); lambda
            (read temp)
           )
           (setq temp (read-line fp))
         ); while
         (close fp)
       )
       (T (alert "无法打开文件 \"LIGHT.INI\" ！"))
     ); cond   
   ); lambda
   (findfile "LIGHT.INI")
  )
  
  (cond
    (blkinf
      (cond (wire_layer) (T (setq wire_layer (getvar "CLAYER"))))
      (prompt (strcat "\n默认图层：\"" wire_layer "\"。" ))
      (cond
        ((= (cdar (laychk wire_layer)) "No")
          (laychk (setq wire_layer (getvar "CLAYER")))
          (prompt (strcat "\n图层被设为当前层：\"" wire_layer "\"。" ))
        )
      ); cond
   
      (while (not flag)
        (initget 1 "Layer Hor Ver")
        (setq flag (getkword "\n图层 L / 垂直 V / 水平 H："))
        (cond
          ((= "Layer" flag)
           (setq temp wire_layer flag nil)
           (setq wire_layer (getstring (strcat "\n请选择图层：<"
                                                wire_layer "> ")))
           (cond ((= wire_layer "") (setq wire_layer temp)))
           (cond
             ((= (cdar (laychk wire_layer )) "No")
               (setq wire_layer temp)
               (prompt (strcat "\n图层仍为：\"" wire_layer "\"。" ))
             )
           ); cond
          )
          ((= "Hor" flag) (setq hor T))
          ((= "Ver" flag) (setq inspt (turntrs inspt)) (setq hor nil))
        ); cond
      ); while      
      
      (setq offset '(1 2 3 4))
      (repeat (fix (+ (/ (* insang 2) pi) 0.1))     ; Ajust offset according
        (setq offset (reverse (cdr (reverse (cons (last offset) offset)))))  ; to angle
      ); repeat  

      (setq offset
        (mapcar
          '(lambda (x)
             (cdr (assoc x blkinf))
           ); lambda
           (cond (hor (list (nth 0 offset) (nth 2 offset)))
                 (T (list (nth 1 offset) (nth 3 offset)))) ; cond
        ); mapcar
      ); setq
      (setq offset (list (* inscale (nth 0 offset)) (* -1 inscale (nth 1 offset))))
      
      ((lambda (y)
         (cond (hor (setq m 0)) (T (setq m 1))); cond
         (cond
           ((> (nth m (nth 0 y)) (nth m (nth 1 y)))
            (setq offset (mapcar '(lambda (x)
                                    (* -1.0 x)
                                  ); lambda
                                  offset
                         ); mapcar
            ); setq
           )
         ); cond
       ); lambda
       (car inspt))
      
      (mapcar
        '(lambda (x)
           (setq m 0)
           (while (< m (1- (length x)))
             (setq ppair  
               (mapcar
                 '(lambda (x dx)
                     (cond (hor (list (+ (nth 0 x) dx) (nth 1 x) (nth 2 x)))
                           (T (list (nth 0 x) (+ (nth 1 x) dx) (nth 2 x)))
                     ); cond
                  ); lambda
                  (list (nth m x) (nth (1+ m) x)) offset
               ); mapcar               
             ); setq
             (apply '(lambda (llayer spoint epoint)
                       (entmake (list (cons 0 "LINE")
                                      (cons 8 llayer)
                                      (cons 10 spoint)
                                      (cons 11 epoint)
                                )
                       ); entmake
                    ); lambda
                    (list wire_layer (car ppair) (cadr ppair))   
             ); apply
             (setq m (1+ m))
           ); while
         ); lambda
         inspt
      ); mapcar
    )
    (T (alert "该图块未被正确配置！"))
  ); cond
); defun connect

(defun c:lp() (lplace))
(defun c:lplace() (lplace))

undo.lsp[/COLOR]
;;;  UNDO.LSP made by piggy
;;;
;;;  DESCRIPTION
;;;     These are general error routines which can be called by
;;;     other routine. See AutoCAD 14 ac_bonus.lsp for reference
;;;
;;;  SUBROUTINE INCLUDED IN THIS FILE
;;;     UNDO_INIT
;;;     UNDO_RESTORE
;;;     VAR_SAVE
;;;     VAR_SET  
;;;     VAR_RESTORE
;;;     ERR_INIT
;;;     ERR_MAIN
;;;     ERR_RESTORE
;;;
;;;  DATE: 10/17/98; 03/31/99
;;;
;;;  HISTORY:
;;;    Add routine of mod_att
;;;
;;;  USING METHOD
;;;    ERR_INIT:
;;;      This routine initialzes the error handler. It should be called as:
;;;
;;;      (if (and (not undo_init)
;;;               (equal -1 (load "undo.lsp"  -1))
;;;          );and
;;;        (progn (alert "Error:\n     Cannot find UNDO.LSP.")(exit))
;;;      ); if
;;;
;;;     ARGUMENTS:
;;;       err_init Takes 3 arguments.
;;;     1. - The first element of the argument:
;;;          This is a list of system variables paired with
;;;          the values you want to set them to. i.e. '("CMDECHO" "ATTMODE")
;;;     2. - The second element is a flag
;;;          If it is true, then in the event of an error
;;;          the custom *error* routine will utilize UNDO
;;;          as a cleanup mechanism.
;;;     3. - The third element is a quoted function call.
;;;          You pass a quoted call to the function you
;;;          wish to execute at the end of nomal routine if an error occurs.
;;;          i.e. '(my_special_stuff arg1 arg2...)
;;;          Use this arg if you want to do some specialized clean up
;;;          things that are not already done by the standard bonus_error
;;;          function.
;;;
;;;    ERR_MAIN: Body of error routine
;;;
;;;    ERR_RESTORE: This routine should be called at the end of command to
;;;           restore the VARIABLES, UNDO & *error*.
;;;
;;;    UNDO_INIT: Initialize the UNDO status
;;;
;;;    UNDO_RESTORE: Restore the UNDO status
;;;
;;;    VAR_SAVE: Save the variables. the argument is like '("CMDECHO" "ATTMODE")
;;;
;;;    UNDO_set: Set the variables. the argument is like
;;;              '(("CMDECHO" 0) ( "ATTMODE" 0))
;;;
;;;    UNDO_RESTORE: Restore the variables
;;;
;----------------------------------------------------------------------------
;  GLOBALS:
;     old_undoctl -- old status of UNDO (voided by UNDO_RESTORE)
;     m_lst       -- list of variables (voided by VAR_RESTORE)
;     err_alive   -- indicate error routine is active (voided by ERR_MAIN or
;                    ERR_OLD)
;     err_old     -- old handler of *error* (voided by ERR_MAIN or ERR_OLD)
;----------------------------------------------------------------------------

;----------------------------------------------------------------------------
; Modify attributes according to entity name, attribute name, dxf_item
;----------------------------------------------------------------------------
(defun mod_att(ent id dxf_item)        
  (while (and (/= "ATTRIB" (car (entgetf '(0) ent))) (/= id (car (entgetf '(2) ent))))
    (setq ent (entnext ent))
  ); while  
  ((lambda (x)
        (mapcar '(lambda (y)
                   (setq x (subst y (assoc (car y) x) x))
                 ); lambda
                 dxf_item
        ); mapcar
     (entmod x)
     (entupd ent)
   ); lambda
   (entget ent)
)
); defun mod_att

;----------------------------------------------------------------------------
; Check layer status, return a association list which contains layer information
;----------------------------------------------------------------------------
(defun laychk(lay / l_sta)
  ( (lambda (x)
      (if (not l_s)
          (setq l_s (list (cons x (logand 5 (cdr (assoc 70 (tblsearch "LAYER" x)))))))
      ); if
    ); lambda
    (getvar "CLAYER")
  )
  (if (not (tblsearch "LAYER" lay))
    (progn  
      (initget "Yes No")
      (if (= (setq l_sta (getkword "\n图层不存在，是否建立该图层 ？\(Y/N\)")) "Yes")
        (progn
          (command "_.layer" "n" lay "")
          (setq l_sta 0)
        ); progn
      ); if
    ); progn
    (progn
      (setq l_sta (logand 5 (cdr (assoc 70 (tblsearch "LAYER" lay)))))
      (if (= 1 (logand 1 l_sta))
          (progn
            (initget "Yes No")
            (if (= (getkword "\n该图层被冻结，是否解冻 ？\(Y/N\)") "Yes")
              (command "_.layer" "t" lay "")
              (setq l_sta "No")
             ); if
          ); progn
      ); if
      (if (numberp l_sta)
        (if (= 4 (logand 4 l_sta)) (command "_.layer" "u" lay "")); if
      ); if
    ); progn
  ); if
  ( (lambda (x)
      (cond
        ( (not x)
          (setq l_s (cons (cons lay l_sta) l_s))
        )
        ( (= "No" (cdr x))
          (setq l_s (subst (cons lay l_sta) x l_s))
        )
        ( T l_s)
      ); cond
     ); lambda
     (assoc lay l_s)
  )

); defun chklay

;----------------------------------------------------------------------------
; Restore layer status according to association list l_s
;----------------------------------------------------------------------------
(defun layres()
  (setvar "CLAYER" (car (last l_s)))
  (repeat (length l_s)
    ( (lambda(x)  
        (if (numberp (cdr x))
          (progn
            (if (= 4 (logand 4 (cdr x)))
              (command "_.layer" "lo" (car x) "")
            ); if
            (if (= 1 (logand 1 (cdr x)))
              (command "_.layer" "f" (car x) "")
            ); if
          ); progn
       ); if  
      ); lambda
      (car l_s)
    )
    (setq l_s (cdr l_s))
  ); repeat
); layres

;----------------------------------------------------------------------------
; Get DXF codes
;----------------------------------------------------------------------------
(defun entgetf (index ent)
  ((lambda (e)
      (mapcar '(lambda (x)
                 (cdr (assoc x e))
               ); lambda
               index) ; internal lambda function
    ); lambda
    (entget ent)
  )
); defun entgetf

;----------------------------------------------------------------------------
; Save UNDO status
;----------------------------------------------------------------------------
(defun undo_init (/ cmdecho undo_ctl)   
  (setq cmdecho (getvar "CMDECHO") undo_ctl (getvar "UNDOCTL")) ; Save the value
  (setvar "CMDECHO" 0)

  (if (equal 0 undo_ctl)                ; Make sure undo is fully enable
    (command "_.undo" "_all")
    (command "_.undo" "_control" "_all")
  )

  (if (equal 4 (logand 4 (getvar "UNDOCTL")))   ; Ensure undo auto is off
    (command "_.undo" "_auto" "_off")
  )

  (while (equal 8 (logand 8 (getvar "UNDOCTL"))) ; Place an end mark here
    (command "_.undo" "_end")
  )

  (while (not (equal 8 (logand 8 (getvar "UNDOCTL"))))
    (command "_.undo" "_group")
  )

  (setvar "CMDECHO" cmdecho)
  undo_ctl
); defun undo_init

;----------------------------------------------------------------------------
; Restore UNDO status
;----------------------------------------------------------------------------
(defun undo_restore (/ cmdecho)
  (if old_undoctl
    (progn
      (setq cmdecho (getvar "CMDECHO"))
      (setvar "CMDECHO" 0)

      (if (equal 0 (getvar "UNDOCTL")) (command "_.undo" "_all"))
      (while (equal 8 (logand 8 (getvar "UNDOCTL")))
        (command "_.undo" "_end")
      ); while


      (if (not (equal old_undoctl (getvar "UNDOCTL")))
        (progn
          (cond
            ((equal 0 old_undoctl)
              (command "_.undo" "_control" "_none")
            )
            ((equal 2 (logand 2 old_undoctl))
              (command "_.undo" "_control" "_one")
            )
          )
          (if (equal 4 (logand 4 old_undoctl))
              (command "_.undo" "_auto" "_on")
              (command "_.undo" "_auto" "_off")
          )
        )
      )
      (setq old_undoctl nil)
      (setvar "CMDECHO" cmdecho)
    )
  )
); defun undo_restore

;----------------------------------------------------------------------------
; Save variables
;----------------------------------------------------------------------------
(defun var_save (a)
  (setq m_lst '())
  (repeat (length a)
    (setq m_lst (append m_lst (list (list (car a) (getvar (car a))))))
    (setq a (cdr a))
  )
); defun var_save

;----------------------------------------------------------------------------
; Set variables
;----------------------------------------------------------------------------
(defun var_set (m_lst)
  (repeat (length m_lst)
    (setvar (caar m_lst) (cadar m_lst))
    (setq m_lst (cdr m_lst))
  )
); defun var_set

;----------------------------------------------------------------------------
; Restore variables
;----------------------------------------------------------------------------
(defun var_restore ()
  (repeat (length m_lst)
    (setvar (caar m_lst) (cadar m_lst))
    (setq m_lst (cdr m_lst))
  )
); defun var_restore

;----------------------------------------------------------------------------
; Initialize routine
;----------------------------------------------------------------------------
(defun err_init(e_lst u_enable add_fun)
  (if err_alive (err_restore))          ; To avoid nested call
  (setq err_alive T)
  (var_save e_lst)                      ; Save the modes
  (if u_enable (setq old_undoctl (undo_init))) ; Initialize UNDO status
  (setq err_old *error* *error* err_main) ; Save the handle of *error*
  (if add_fun                           ; Add the user cleaner
    (setq *error* (append (reverse (cdr (reverse *error*)))
                          (list add_fun (last *error*))
                  ); append
    )
  )
); defun err_init

;----------------------------------------------------------------------------
; Error routine body
;----------------------------------------------------------------------------
(defun err_main( msg / )                ; Body of error routine
  (if (/= msg "Function cancelled")     ;If an error (such as CTRL-C) occurs
    (princ (strcat "\nError: " s))      ;while this command is active...
  )
  (while (not (equal (getvar "CMDNAMES") "")) (command nil)) ; Get out of any active command

  (if old_undoctl
    (progn
      (while (not (wcmatch (getvar "CMDNAMES") "*UNDO*")) ; See
        (command "_.undo")              ; if it's in UNOD command
      )
      (command "_end")
      (command "_.undo" "1")
      (while (not (equal (getvar "CMDNAMES") "")) (command nil))
      (undo_restore)                    ; Restore the status of UNDO
    )
  )

  (var_restore)                         ; Restore the variables
  (if err_old (setq *error* err_old err_old nil)) ; Restore the handle of error
  (setq err_alive nil)
  (princ)
); defun err_main

;----------------------------------------------------------------------------
; Restore error status
;----------------------------------------------------------------------------
(defun err_restore()
  (undo_restore)                        ; Restore the status of UNDO
  (var_restore)                         ; Restore the variables
  (if err_old (setq *error* err_old err_old nil)) ; Restore the handle of error
  (setq err_alive nil)
  (princ)
); defun err_restore