[v_alex]

задачка для людей знающих Lisp:

есть созданный блок... например квадрат... точка вставки левый нижний угол... нужно сделать точкой вставки допустим правый верхний... надо сделать так чтобы не открывая refedit перенести точку вставки... простыми словами - изменить точку вставки блока тремя кликами... один клик на кнопке, второй на блоке... третий на новой точке вставки...

[Лентяй]

Дак как два байта ! На кнопку ToolBar вешаем соотв. прогу ChInsPt.lsp. По приглащению "Select Block: " выбираем блок. По приглашению "Select Point: " указываем новую точку вставки. Алгритм же такой. (1) вычисляется вектор переноса точки вставки в пределах объекта BlockReference. (2) Координты точки вставки изменяются нс указанный вктор в объекте Block коллекции Blocks (3) Регенерируется соотв. объект. Конкретно ChInsPt.lsp могу написать только завтра проспавшись.

[v_alex]

Сообщение от Лентяй Конкретно ChInsPt.lsp могу написать только завтра проспавшись.

Ну и ленивый же ты... столько спать... буду весьма признателен...

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

Только надо дополнительно обрабатывать атрибуты, однострочные и многострочные тексты с выравниванием "не влево". Изменение originpoint для описания блока может сработать некорректно.
---
Добавлено: Сильно подозреваю, что vla-функции здесь не покатят, надо использовать (entget) и (entmake).

[Лентяй]

Сообщение от v_alex Сообщение от Лентяй Конкретно ChInsPt.lsp могу написать только завтра проспавшись. Ну и ленивый же ты... столько спать... буду весьма признателен...

Держите, злодей, первоначальную прикидку. Учет масштабирования по осям, равно как и обработку элементов, перечисленных kpblc'ом я не вводил. Но, полагаю. что идея ясна и так.

Код:

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

(defun selobj ()
  (if (not (vl-catch-all-error-p (vl-catch-all-apply 
      '(lambda () (vla-getEntity util 'obj nil "Select Block: ")))));not
  obj
  (progn (alert "Nothibg Selected. Try Again!") (selobj)))
  (if (/= (vla-get-ObjectName obj) "AcDbBlockReference")
    (alert "This Is Not A Block! Try Again!") obj)
);selobj
;
(defun C:ChInsPt ( / adoc util bks bk)
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(util bks) '("Utility" "Blocks"))
  (vla-endundomark adoc) (vla-startundomark adoc)
  (vla-highlight (selobj) t)
  (setq ip0 (vla-get-InsertionPoint obj)
        ip1 (vla-getPoint util nil "Select New Insertion Point")
        rv (mapcar '(lambda (y) (apply y (mapcar '(lambda (x) (vlax-safearray->list (vlax-variant-value x)))
                             (list ip0 ip1)))) '(distance angle))
        bk (vla-item bks (vla-get-name obj))
        ip (vlax-get bk 'Origin));setq
  (vla-put-origin bk (vlax-3d-point (polar ip (cadr rv) (car rv))))
  (vla-update obj)
  (vla-regen adoc acAllViewports)
  (vla-endundomark adoc) 
);end

Вот тепреь точно пошел спать.

[Лентяй]

Так и быть. вот вам и с учетом масштабирования по ХУ и поворота. Теперь точно ушел.

Код:

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

(defun selobj ()
  (if (not (vl-catch-all-error-p (vl-catch-all-apply 
      '(lambda () (vla-getEntity util 'obj nil "Select Block: ")))));not
  obj
  (progn (alert "Nothibg Selected. Try Again!") (selobj)))
  (if (/= (vla-get-ObjectName obj) "AcDbBlockReference")
    (alert "This Is Not A Block! Try Again!") obj)
);selobj
;
(defun C:ChInsPt ( / adoc util bks bk prp)
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (mapcar '(lambda (x y) (set x (vlax-get-property adoc y))) '(util bks) '("Utility" "Blocks"))
  (vla-endundomark adoc) (vla-startundomark adoc)
  (vla-highlight (selobj) t)
  (setq prp (mapcar '(lambda (x) (vlax-get-property obj x))
              '(InsertionPoint XScaleFactor YScaleFactor Rotation))
        ip1 (vla-getPoint util nil "Select New Insertion Point")
        rv (mapcar '(lambda (y) (apply y (mapcar '(lambda (x) (vlax-safearray->list (vlax-variant-value x)))
                             (list (car prp) ip1)))) '(distance angle))
        bk (vla-item bks (vla-get-name obj)));setq
  (vla-put-origin bk (vlax-3d-point (polar (vlax-get bk 'Origin)
                                      (* (cadr rv) (/ (nth 1 prp) (nth 2 prp))) (- (car rv) (last prp)))))
  (vla-update obj)
  (vla-regen adoc acAllViewports)
  (vla-endundomark adoc) 
);end