AfraLisp Blog

The AutoLisp/Visual Lisp/VBA Resource Website

AfraLisp Blog

Home Newsletter Utter Rubbish Coding Tips AutoCAD Tips Contact Downloads WAUN

I get material from your site quite often, and I think it is time to give
something back. I am sending a routine in lisp to project-align TEXT and
BlOCK entities upon an existing line. Quite useful when drawing parking
stalls, etc.

Rogelio Bravo

;CODING STARTS HERE
;; project/align texts and blocks upon preexistent line
(defun C:aligne ()
(prompt "\nPick base line upon which project/align objects:")
(setq ent (entsel))
(setq pt2 (cadr ent))
(setq nlin (car ent))
(setq pt2 (osnap pt2 "Nea"))

(prompt "\nSelect texts/blocks to project/align: ")
(setq conj (ssget))
(setq num 0)
(setq con (ssadd))
(setq lon (sslength conj))
(repeat lon
(setq name (ssname conj num))
(setq lst (entget name))
(setq tip (cdr (assoc 0 lst)))
(if (or (= tip "TEXT")(= tip "INSERT")) ;seleccion objetos texto o bloque
(ssadd name con)
)
(setq num (+ 1 num))
) ; end repeat
(setq lon1 (sslength con))
(setq num1 0)
(repeat lon1
(setq e1 (entget (ssname con num1))) ; lista de la primera entidad
(setq pt1 ( cdr (assoc 10 e1))) ;punto inserción texto o bloque
(setq name (cdr (assoc -1 e1)))
( command "line" pt1 (osnap pt2 "per") "")
;obtención punto final de la recta perpendicular
(setq pfin (cdr (assoc 11 (entget (entlast)))))
(command "_erase" (entlast) "")
(command "_move" name "" pt1 pfin)
(setq num1 (+ 1 num1))
);end repeat
(initget "Yes No")
(setq what (getkword "\n¿Erase base line? (Y/N) <Y>: "))
(if (= what nil)(setq what "Yes"));end if
(cond
((= what "Yes")(command "_erase" nlin ""))
); end cond
(princ)
) ; end defun

;CODING ENDS HERE

The AutoLisp/Visual Lisp/VBA Resource Website

Copyright © 1999-Perpetuity by AfraLisp

All rights reserved.
Information in this document is subject to change without notice.
Site created and maintained by Kenny Ramage

The AutoLisp/Visual Lisp/VBA Resource Website