[编程交流] 自动布局 LISP

(defun c:test (/ a cnt en entg entg_pline lista n num_str p1 p2 pini pins pline pt
             ss1 ss2)
  (setvar "cmdecho" 0)
  (command ".ucs" "world")
  (if (null (tblsearch "layer" "defpoints"))
    (command ".layer" "m" "defpoints" "c" "7" "" "")
  )
  (if (setq pline (entsel "\nSelect the road axis:"))
    (progn
      (redraw (car pline) 3) ;_highlight object
      (if (setq pini (getpoint
                       "\nSelect a point near the beginning of the road pline: "
                     )
          )
        (progn
          (setq entg_pline (entget (car pline)))
          (setq lista nil)
          (mapcar '(lambda (a)
                     (if (= (car a) 10)
                       (setq lista (cons (cdr a) lista))
                     )
                   )
                  entg_pline
          )
          (if (
            (setq lista (reverse lista))
          )
          (setq ss1 (ssget "f" lista (list (cons '2 "viewport"))))
          (setq cnt (sslength ss1))
          (if (> cnt 0)
            (progn
              (setq n 0)
              (repeat cnt
                (setq entg (entget (setq en (ssname ss1 n))))
                (setq n (1+ n))
                (setq pins (cdr (assoc 10 entg)))
                (setq pt (polar pins (cdr (assoc 50 entg)) 400))
                (setq p1
                       (polar pins (+ (* pi 0.5) (cdr (assoc 50 entg))) 291.7293)
                )
                (setq p2
                       (polar pins (+ (* pi 1.5) (cdr (assoc 50 entg))) 291.7293)
                )
                (setq p2 (polar p2 (cdr (assoc 50 entg)) 844.4204))
                (setq num_str (rtos n 2 0))
                (if (= (strlen num_str) 1)
                  (setq num_str (strcat "0" num_str))
                )
                ;;;_the number is for verification
                ;;;_layer defpoints does not plot
                (entmakex (list (cons 0 "TEXT")
                                (cons 1 num_str)
                                (cons 10 pt)
                                (cons 11 pt)
                                (cons 8 "defpoints")
                                (cons 40 200)
                                (cons 50 (cdr (assoc 50 entg)))
                                (cons 72 1)
                                (cons 73 2)
                          )
                )
                (command ".-layout" "copy" "template" num_str)
                (command ".-layout" "set" num_str)
                (setq
                  ss2 (ssget
                        "x"
                        (list (cons 0 "VIEWPORT") (cons 410 (getvar "ctab")))
                      )
                )
                (vla-put-displaylocked (vlax-ename->vla-object (ssname ss2 0))
                                       :vlax-false
                )
                (command ".mspace")
                (command ".ucs" "ob" en)
                (command ".plan" "")
                (command ".zoom" "w" (trans p1 0 1) (trans p2 0 1))
                (command ".pspace")
                (setvar "tilemode" 1)
              )
              (command ".-layout" "delet" "template")
            )
          )
        )
      )
    )
  )
  (if pline
    (redraw (car pline) 4) ;_unhighlight object
  )
  (princ)
)