[Дмитрий Факс]

День добрый, уважаемые! Вот скачал на форуме лисп "Построение прямоугольника из его центра":

Код:

[Выделить все]

(defun C:РПРЯМОУГ (/ OLDVAR *adoc* s)

  ;; настроить переменные
  (foreach x
   '("cmdecho" "plinewid" "osnapcoord" "osmode")
    (setq OLDVAR (cons (list x (getvar x)) OLDVAR))
  )
  (setq *adoc* (vla-get-ActiveDocument (vlax-get-acad-object)))
  (vla-StartUndoMark *adoc*)

  (setvar "cmdecho" 0)
  (setvar "plinewid" 0)
  (setvar "osnapcoord" 1)

  ;; если нужно, добавить привязки "_nea,_end,_int,_per,"
  (foreach x '(512 1 32 128)
    (if (= 0 (logand x (getvar "osmode")))
      (setvar "osmode" (+ x (getvar "osmode")))
    )
  )
  ;; активизировать режим привязок
  (setvar "osmode" (logand -16385 (getvar "osmode")))

  ;;------------------------------------------
  ;; ПОДфункция анализа задаваемого параметра.
  ;; Допускает ввод строки, которая после
  ;; замены запятой на точку преобразуется в
  ;; положительное число.
  ;; Возвращает положительное число или nil.
  ;;------------------------------------------
  (defun *realval* (VAL* / lst)
    (if
      (and VAL*
        (or
          (numberp VAL*) ;; если введено число
          (numberp
            (setq VAL* ;; или если введенная строка c преобразуется в число...
              (vl-catch-all-apply (function (lambda ()
                (read
                  (vl-list->string
                    (progn
                      ;; удалить пробелы и заменить запятые на точки
                      (setq lst (subst 46 44 (vl-remove '32 (vl-string->list VAL*))))
                      (cond
                        ;; если целое число — добавить точку и ноль
                        ((not (member 46 lst))(append lst '(46 48)))

                        ;; если точка перед числом — добавить ноль перед точкой
                        ((= (car lst) 46)(cons 48 lst))
                        (T lst)
                      )
                    ) ;;...progn
                  ) ;;... vl-list->string
                ) ;;...read
              ))) ;;...vl-catch-all-apply
            ) ;;...setq
          ) ;;...numberp
        ) ;;...or

        (> VAL* 0) ;; если число положительное
      ) ;;...and

       VAL* ;; результат — число
    ) ;;...if
  ) ;;...defun *realval*

  ;;----------------------------------
  ;; Основная функция
  ;;----------------------------------
  (princ "\n'\nU_КОМАНДА: РПРЯМОУГ (Прямоугольники по заданным размерам)")

  (defun *go* (/ l h ptc pt1 pt2 pt3 pt4)

    ;; начальные размеры прямоугольника
    (mapcar
      (function (lambda (param nval)
        (if (not (and (getenv param)(numberp (read (getenv param)))))
          (setenv param nval)
        )
      ))
     '("u_rrect_L" "u_rrect_H") '("10" "10")
    )

    ;; назначить параметры...
    (while
      ((lambda (/ xl)
        (princ (strcat "\nШирина <" (getenv "u_rrect_L") ">: "))
        (initget 128)(setq xl (getreal))
        (cond
          ((not xl) nil)
          ((setq xl (*realval* xl))(setenv "u_rrect_L" (vl-princ-to-string xl)) nil)
          (T (alert "Допустим ввод только положительных чисел!") T)
        )
      ))
    )
    (while
      ((lambda (/ xh)
        (princ (strcat "\nВысота <" (getenv "u_rrect_H") ">: "))
        (initget 128)(setq xh (getreal))
        (cond
          ((not xh) nil)
          ((setq xh (*realval* xh))(setenv "u_rrect_H" (vl-princ-to-string xh)) nil)
          (T (alert "Допустим ввод только положительных чисел!") T)
        )
      ))
    )
    (setq l   (read (getenv "u_rrect_L")) ;; ширина
          h   (read (getenv "u_rrect_H")) ;; высота
          ptc (cadr (grread T 12))        ;; центр (pickbox отлючен 4+8)
          pt1 (polar                      ;; левая верхняя
                (polar ptc pi (* 0.5 l))
                (* 1.5 pi)
                (* 0.5 h)
              )
          pt2 (polar pt1 0 l)             ;; правая верхняя
          pt3 (polar pt2 (* 0.5 pi) h)    ;; правая нижняя
          pt4 (polar pt3 pi l)            ;; левая нижняя
    )

    (vl-cmdf "_.PLINE" pt1 pt2 pt3 pt4 "_CL") ;; изобразить прямоугольник
    (setq s (entlast)) ;; обозначить прямоугольник-оригинал

    (mapcar (function princ)(list "\n'\nШирина = " l "   Высота = " h "   Точка вставки: "))

    ;; задержка до начала движения курсора (pickbox отлючен)
    (while (equal ptc (cadr (grread T 12))))

    (redraw s 2) ;; погасить оригинал

    ;; цикл мультикопирования
    (while s
      (vl-cmdf "_.MOVE" s "" ptc pause) ;; выполнить перенос оригинала

        ;; если при переносе была отмена правой клавишей...
        (if (equal ptc (getvar "lastpoint"))
        (progn
          (entdel s)   ;; удалить оригинал
          (setq s nil) ;; прервать цикл
        )
        (progn ;; ...иначе
          (setq ptc (getvar "lastpoint")) ;; скорректировать базовую точку
          (vl-cmdf "_.COPY" s "" ptc ptc) ;; сделать копию оригинала
          (princ "\nТочка вставки: ")
        )
      ) ;;...if equal
    ) ;;...while
  ) ;;...defun *go*

  ;; удалить оригинал при сбое
  (if (vl-catch-all-error-p (vl-catch-all-apply (function *go*)))
    (if s (entdel s))
  )

  (vla-EndUndoMark *adoc*)
  (foreach x OLDVAR (setvar (car x)(cadr x)))
  (princ)
)

Хорошая функция, но хотелось бы большего. А именно:
1. Указывать длину и ширину указателем мыши на экране;
2. Чтобы прямоугольник строился не по точке пересечения диагоналей, а по центру верхней стороны.

Надеюсь объяснил понятно. Кто может помогите пожалуйста.

[Кулик Алексей aka kpblc]

На нормальное название темы - 12 часов.

[vasilyis]

И хорошо было перенести тему в раздел Программироание.

[Кулик Алексей aka kpblc]

vasilyis, легко! Сделано