Реклама i
Стань нашим партнером - зарабатывай с нами!
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен лисп (super offset)

Нужен лисп (super offset)

Закрытая тема
Поиск в этой теме
Непрочитано 20.06.2007, 10:28 #1
Нужен лисп (super offset)
dextron3
 
проектировшик
 
СССР
Регистрация: 01.01.2007
Сообщений: 5,143

Как лисп должен работать:

1. Выделяем множество замкнутых фигур
2. Выполняется оффсет всех фигур на 100мм внутрь
3. Вычерчиваются новые офсетные фигуры, а старые удаляются


Для чего нужно:
1. Подсчет подбетонки (обычно фундаментные ленты начерчены чтобы их найти объем достаточно площадь умножить на высоту, это легко, а вот чтобы найти объем подбетонки нужно офсетить прямоугольники внутри внутрь на 100мм, а с наружи наружу, кропотливая работа, затем находим площадь и умножаем на высоту вот и объем подбетонки

2. Для подсчета щебня, гравия и тп.
3. Нужный лисп для каждого конструктора
[ATTACH]1182320890.JPG[/ATTACH]

:roll: :roll: :roll: :roll: :roll:
__________________
инженер проектировшик с опттом программа авто гад образование высшие
Просмотров: 6086
 
Автор темы   Непрочитано 20.06.2007, 12:43
#2
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


На картинке нарисована фундаментная лента и подбетонка, разница в толщине, которая равна по 100мм с каждой стороны
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 21.06.2007, 00:27
#3
fixo

Lisp/VBA/VB.NET Hobbyist
 
Регистрация: 24.03.2005
Славен Град Петров
Сообщений: 367


В свое время делал подобное для одного стекольщика
Переделай под свои нужды

Код:
[Выделить все]
(defun C:OOF()
(setq osm (getvar "osmode"))
(setq ofs (getvar "offsetdist"))
(setvar "cmdecho" 0)
(setvar "osmode" 1)
(command "_.undo" "_be")  
(setq p1 (getpoint "\n  Specify first corner >>")
p2 (getcorner p1 "\n  Specify opposite corner >>")
)  
(if 
(setq ss (ssget "_W" p1 p2 '((0 . "*POLYLINE")(-4 . "&=")(90 . 4)(70 . 1))))
(progn
(sssetfirst ss ss)
(initget 6)  
(setq dis (getreal "\n  Specify offset distance <100> : "))
(if (not dis)(setq dis 100.0))
(setvar "offsetdist" dis)
(setq sign (getstring "\n  Specify offset direction (outside + / inside -) <+> : "))
(if (eq "" sign)(setq sign "+"))

(setvar "osmode" 0)
(setq i -1)
(repeat (sslength ss)
(setq en (ssname ss (setq i (1+ i))))
(setq coors (vl-remove-if (function not)
	(mapcar (function (lambda (x)
	(if (= 10 (car x))(cdr x))))
		(entget en)))
)
(setq p1 (car coors) p2 (caddr coors))
(if (eq "+" sign)
(setq po (polar p2 (angle p1 p2) dis))
(setq po (polar p2 (angle p2 p1) dis)))
(command "_.offset" "" en (trans po 0 1) "")
)
(command "_.erase" ss "")
)
(princ "\n 0 objects selected")
)
(setvar "osmode" osm)
(setvar "offsetdist" ofs)
(setvar "cmdecho" 1)
(command "_.undo" "_e")   
(princ)
)
~'J'~
fixo вне форума  
 
Автор темы   Непрочитано 21.06.2007, 08:05
#4
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


Fatty

Почему во всех твоих лиспах после выполнения отключаются привязки, приходится их постоянно включать, это гдето в лиспе прописано чтоли?
[ATTACH]1182398712.JPG[/ATTACH]

:roll: :roll: :roll:
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 21.06.2007, 08:53
#5
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Я код не тестировал совершенно, так что если что не так - сообщи.
Код:
[Выделить все]
(vl-load-com)
(defun c:ooff2
	       (/		  *error*	    _kpblc-error-sysvar-restore
		_kpblc-error-sysvar-save	    adoc
		pt1		  pt2		    selset
		dis		  sign		    coord
		)

  (defun _kpblc-error-sysvar-restore (lst)
				     ;|
*    Восстаналивает значения системных переменных.
*    Параметры вызова:
*	lst	список системных переменных, значения которых восстанавливаются
*		nil -> восстанавливать все
|;
    (if	lst
      (foreach sysvar lst
	(setvar sysvar (car (assoc sysvar *kpblc-list-sysvar*)))
	) ;_ end of foreach
      (progn
	(foreach sysvar	*kpblc-list-sysvar*
	  (setvar (car sysvar) (cadr sysvar))
	  ) ;_ end of foreach
	(setq *kpblc-list-sysvar* nil)
	) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of defun

  (defun _kpblc-error-sysvar-save (lst)
				  ;|
*    Сохраняет текущее значение переданных системных переменных в глобальном
* списке *kpblc-list-sysvar*
*    Параметры вызова:
*	lst	список системных переменных (возможно, с переданными значениями)
*    Примеры вызова:
(_kpblc-error-sysvar-save '(("osmode" 512) ("orthomode" 1)))
*    Возвращаемое значение:	нет
|;
    (foreach sysvar lst
      (setq *kpblc-list-sysvar*
	     (cons (list (car sysvar) (getvar (car sysvar)))
		   *kpblc-list-sysvar*
		   ) ;_ end of append
	    ) ;_ end of setq
      (if (cdr sysvar)
	(setvar (car sysvar) (cadr sysvar))
	) ;_ end of if
      ) ;_ end of foreach
    (princ)
    ) ;_ end of defun

  (defun *error* (msg)
    (_kpblc-error-sysvar-restore nil)
    (vla-endundomark adoc)
    (princ msg)
    (princ)
    ) ;_ end of defun

  (vla-startundomark
    (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of vla-StartUndoMark
  (if (and (not	(vl-catch-all-error-p
		  (vl-catch-all-apply
		    '(lambda ()
		       (setq pt1 (getpoint "\nПервый угол <Отмена> : "))
		       ) ;_ end of lambda
		    ) ;_ end of vl-catch-all-apply
		  ) ;_ end of vl-catch-all-error-p
		) ;_ end of not
	   pt1
	   (not	(vl-catch-all-error-p
		  (vl-catch-all-apply
		    '(lambda ()
		       (setq pt2 (getcorner pt1 "\nВторой угол <Отмена> : "))
		       ) ;_ end of lambda
		    ) ;_ end of vl-catch-all-apply
		  ) ;_ end of vl-catch-all-error-p
		) ;_ end of not
	   pt2
	   ) ;_ end of and
    (progn
      (_kpblc-error-sysvar-save '(("cmdecho" 0) ("osmode" 1)))
      (if (setq	selset (ssget "_W"
			      pt1
			      pt2
			      '((0 . "*POLYLINE") (-4 . "&=") (90 . 4) (70 . 1))
			      ) ;_ end of ssget
		) ;_ end of setq
	(progn
	  (sssetfirst selset selset)
	  (initget 6)
	  (if (not (vl-catch-all-error-p
		     (vl-catch-all-apply
		       '(lambda	()
			  (setq
			    dis	(getreal "\nРасстояние offset'a <100.0> : ")
			    ) ;_ end of setq
			  ) ;_ end of lambda
		       ) ;_ end of vl-catch-all-apply
		     ) ;_ end of vl-catch-all-error-p
		   ) ;_ end of not
	    (setq dis 100.)
	    ) ;_ end of if
	  (_kpblc-error-sysvar-save (list (list "offsetdist" dis)))
	  (if (not (vl-catch-all-error-p
		     (vl-catch-all-apply
		       '(lambda	()
			  (initget "Наружу Внутрь Outside Inside _ O I O I")
			  (setq	sign
				 (cond
				   ((getkword
				      "\nУкажите направление offset'a [Наружу/Внутрь] <Наружу> : "
				      ) ;_ end of GETKWORD
				    )
				   (t "O")
				   ) ;_ end of cond
				) ;_ end of setq
			  ) ;_ end of lambda
		       ) ;_ end of vl-catch-all-apply
		     ) ;_ end of vl-catch-all-error-p
		   ) ;_ end of not
	    (progn
	      (_kpblc-error-sysvar-save '(("osmode" 0)))
	      (foreach item
		       (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
		(setq coord (vl-remove-if-not
			      '(lambda (x) (= (car x) 10))
			      (entget item)
			      ) ;_ end of vl-remove-if-not
		      pt1   (car coord)
		      pt2   (caddr coord)
		      po    (polar pt2
				   (if (= sign "O")
				     (angle pt1 pt2)
				     (angle pt2 pt1)
				     ) ;_ end of if
				   dis
				   ) ;_ end of polar
		      ) ;_ end of setq
		(command "_.offset" "" item (trans po 0 1) "")
		) ;_ end of foreach
	      (command "_.erase" selset "")
	      ) ;_ end of progn
	    ) ;_ end of if
	  ) ;_ end of progn
	) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  (_kpblc-error-sysvar-restore nil)
  (vla-endundomark adoc)
  (princ)
  ) ;_ end of defun
---
Добавлено: сам алгоритм я не менял, он полностью принадлежит Fatty. Моего только обработка ошибок.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 21.06.2007, 09:41
#6
SergGL

инженер
 
Регистрация: 13.08.2006
г. Пенза
Сообщений: 113


2kpblc
Весьма благодарен. Привязки не отключаются. Все работает.
__________________
MEMENTO QUOD ES HOMO
SergGL вне форума  
 
Автор темы   Непрочитано 21.06.2007, 11:22
#7
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


Кулик Алексей aka kpblc
Модератор


а вот первичный приметив она не удаляет когда строит офсетный новый можешь подкорректировать

ждемс
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 21.06.2007, 14:59
#8
fixo

Lisp/VBA/VB.NET Hobbyist
 
Регистрация: 24.03.2005
Славен Град Петров
Сообщений: 367


Цитата:
Сообщение от Fatty
В свое время делал подобное для одного стекольщика
Переделай под свои нужды

Код:
[Выделить все]
(defun C:OOF()
(setq osm (getvar "osmode"))
(setq ofs (getvar "offsetdist"))
(setvar "cmdecho" 0)
(setvar "osmode" 1)
(command "_.undo" "_be")  
(setq p1 (getpoint "\n  Specify first corner >>")
p2 (getcorner p1 "\n  Specify opposite corner >>")
)  
(if 
(setq ss (ssget "_W" p1 p2 '((0 . "*POLYLINE")(-4 . "&=")(90 . 4)(70 . 1))))
(progn
(sssetfirst ss ss)
(initget 6)  
(setq dis (getreal "\n  Specify offset distance <100> : "))
(if (not dis)(setq dis 100.0))
(setvar "offsetdist" dis)
(setq sign (getstring "\n  Specify offset direction (outside + / inside -) <+> : "))
(if (eq "" sign)(setq sign "+"))

(setvar "osmode" 0)
(setq i -1)
(repeat (sslength ss)
(setq en (ssname ss (setq i (1+ i))))
(setq coors (vl-remove-if (function not)
	(mapcar (function (lambda (x)
	(if (= 10 (car x))(cdr x))))
		(entget en)))
)
(setq p1 (car coors) p2 (caddr coors))
(if (eq "+" sign)
(setq po (polar p2 (angle p1 p2) dis))
(setq po (polar p2 (angle p2 p1) dis)))
(command "_.offset" "" en (trans po 0 1) "")
)
(command "_.erase" ss "")
)
(princ "\n 0 objects selected")
)
(setvar "osmode" osm)
(setvar "offsetdist" ofs)
(setvar "cmdecho" 1)
(command "_.undo" "_e")   
(princ)
)
~'J'~
У меня работает и все восстанавливается
Автокад казахский наверно

~'J'~
fixo вне форума  
 
Непрочитано 21.06.2007, 15:30
#9
Alaspher


 
Регистрация: 11.10.2004
e•burg
Сообщений: 755


Осмелюсь предложить вариант без применения command:
Код:
[Выделить все]
(vl-load-com)
(defun c:ooff3 (/               adoc            pl:is-lwpoly-clock
                pl:obj-filter-select-manual     locs            asel            isclock
                isint           lays            isdel           tmp
               )
  (defun pl:is-lwpoly-clock (lwpl / pnts angl)
    (setq pnts (mapcar (function cdr)
                       (vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget lwpl))
               )
          angl (mapcar (function angle) (cons (last pnts) pnts) pnts)
    )
    (minusp (apply (function +)
                   (mapcar (function (lambda (b)
                                       (cond ((< (abs b) pi) b)
                                             ((minusp b) (+ (* 2 pi) b))
                                             (t (+ (* -2 pi) b))
                                       )
                                     )
                           )
                           (mapcar (function -) angl (cons (last angl) angl))
                   )
            )
    )
  )
  (defun pl:obj-filter-select-manual (sel filter)
    (vla-selectonscreen
      sel
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbinteger (cons 1 (length filter)))
        (mapcar (function car) filter)
      )
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbvariant (cons 1 (length filter)))
        (mapcar (function cdr) filter)
      )
    )
  )
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        lays (vla-get-layers adoc)
        asel (vla-get-activeselectionset adoc)
  )
  (vla-clear asel)
  (pl:obj-filter-select-manual asel '((0 . "LWPOLYLINE")))
  (vlax-for i asel
    (if (= :vlax-true (vla-get-lock (vla-item lays (vla-get-layer i))))
      (setq locs (cons i locs))
    )
  )
  (if locs
    (vla-removeitems
      asel
      (vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length locs)))) locs)
    )
  )
  (if (zerop (vla-get-count asel))
    (princ "\nНе выбрано полилиний на незаблокированных слоях.")
    (progn
      (initget "В Н _I O")
      (if (not (setq isint (getkword "\nНаправление офсета [Внутрь, Наружу] <Внутрь>: ")))
        (setq isint "I")
      )
      (if (/= (type pl:ooff-dist) 'REAL)
        (setq pl:ooff-dist 100.0)
      )
      (initget 6)
      (if (setq tmp (getdist (strcat "\nУкажи дистанцию <" (rtos pl:ooff-dist) ">: ")))
        (setq pl:ooff-dist tmp)
      )
      (vla-startundomark adoc)
      (vlax-for i asel
        (vla-offset
          i
          (if
            (or (and (setq isclock (pl:is-lwpoly-clock (vlax-vla-object->ename i))) (= isint "I"))
                (and (/= isint "I") (not isclock))
            )
             pl:ooff-dist
             (- pl:ooff-dist)
          )
        )
      )
      (vla-endundomark adoc)
      (initget "Д Н _Y N")
      (if (not (setq isdel (getkword "\nУдалить исходные примитивы [Да, Нет] <Да>: ")))
        (setq isdel "Y")
      )
      (if (= isdel "Y")
        (progn (vla-startundomark adoc) (vla-erase asel) (vla-endundomark adoc))
      )
    )
  )
  (princ)
)
* WARNING
Серьёзно не тестировал!
Alaspher вне форума  
 
Автор темы   Непрочитано 21.06.2007, 18:41
#10
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


Alaspher

Реальная штуковина!
Даже на казахском автокаде работает!

только почемуто сначало нужно выделять приметивы а потом команду включать если сразу команду то выдает это:

Command: OOFF3
; error: Automation Error. Calling method AddItems of interface
IAcadSelectionSet failed


нельзя лисп подредоктировать случаем?
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 21.06.2007, 20:12
#11
fixo

Lisp/VBA/VB.NET Hobbyist
 
Регистрация: 24.03.2005
Славен Град Петров
Сообщений: 367


Цитата:
Сообщение от dextron3
Alaspher

Реальная штуковина!
Даже на казахском автокаде работает!

только почемуто сначало нужно выделять приметивы а потом команду включать если сразу команду то выдает это:

Command: OOFF3
; error: Automation Error. Calling method AddItems of interface
IAcadSelectionSet failed


нельзя лисп подредоктировать случаем?
Лишний раз говорит о том что у тебя проблемы
с АвтоКадом
У меня программа Alasphera тоже работает без
всяких проблем

~'J'~
fixo вне форума  
 
Непрочитано 21.06.2007, 23:30
#12
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Может, просто слой , на котором лежит "исходник", заблокирован?
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Автор темы   Непрочитано 22.06.2007, 08:23
#13
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


может из за того что лисп дается для русского автокада а у меня английский?

остальные же лиспы работают нормально

почему то не работают лиспы от:
Fatty
Кулик Алексей aka kpblc
Alaspher


Работают только лиспы VVA
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 22.06.2007, 08:44
#14
Alaspher


 
Регистрация: 11.10.2004
e•burg
Сообщений: 755


Цитата:
Сообщение от dextron3
нельзя лисп подредоктировать случаем?
Кабы знать, что редактировать - воспроизвести проблему мне не удалось.

Цитата:
Сообщение от Fatty
Лишний раз говорит о том что у тебя проблемы
с АвтоКадом
Не исключено.

Цитата:
Сообщение от Кулик Алексей aka kpblc
Может, просто слой , на котором лежит "исходник", заблокирован?
Обработка блокировок предусмотрена.

Цитата:
Сообщение от dextron3
может из за того что лисп дается для русского автокада а у меня английский?
command и ssget я не использовал, а в другие части локализаторы соваться не должны.

Нашёл мелкий косячок в диалогах (100 лет не писал интерфейсов ), но на остальном это сказываться не должно.

Исправленный код:
Код:
[Выделить все]
(vl-load-com)
(defun c:ooff3 (/               adoc            pl:is-lwpoly-clock
                pl:obj-filter-select-manual     locs            asel            isclock
                isint           lays            isdel           tmp
               )
  (defun pl:is-lwpoly-clock (lwpl / pnts angl)
    (setq pnts (mapcar (function cdr)
                       (vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget lwpl))
               )
          angl (mapcar (function angle) (cons (last pnts) pnts) pnts)
    )
    (minusp (apply (function +)
                   (mapcar (function (lambda (b)
                                       (cond ((< (abs b) pi) b)
                                             ((minusp b) (+ (* 2 pi) b))
                                             (t (+ (* -2 pi) b))
                                       )
                                     )
                           )
                           (mapcar (function -) angl (cons (last angl) angl))
                   )
            )
    )
  )
  (defun pl:obj-filter-select-manual (sel filter)
    (vla-selectonscreen
      sel
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbinteger (cons 1 (length filter)))
        (mapcar (function car) filter)
      )
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbvariant (cons 1 (length filter)))
        (mapcar (function cdr) filter)
      )
    )
  )
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        lays (vla-get-layers adoc)
        asel (vla-get-activeselectionset adoc)
  )
  (vla-clear asel)
  (pl:obj-filter-select-manual asel '((0 . "LWPOLYLINE")))
  (vlax-for i asel
    (if (= :vlax-true (vla-get-lock (vla-item lays (vla-get-layer i))))
      (setq locs (cons i locs))
    )
  )
  (if locs
    (vla-removeitems
      asel
      (vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length locs)))) locs)
    )
  )
  (if (zerop (vla-get-count asel))
    (princ "\nНе выбрано полилиний на незаблокированных слоях.")
    (progn
      (initget "В Н _I O")
      (if (not (setq isint (getkword "\nНаправление офсета [Внутрь/Наружу] <Внутрь>: ")))
        (setq isint "I")
      )
      (if (/= (type pl:ooff-dist) 'REAL)
        (setq pl:ooff-dist 100.0)
      )
      (initget 6)
      (if (setq tmp (getdist (strcat "\nУкажи дистанцию <" (rtos pl:ooff-dist) ">: ")))
        (setq pl:ooff-dist tmp)
      )
      (vla-startundomark adoc)
      (vlax-for i asel
        (vla-offset
          i
          (if
            (or (and (setq isclock (pl:is-lwpoly-clock (vlax-vla-object->ename i))) (= isint "I"))
                (and (/= isint "I") (not isclock))
            )
             pl:ooff-dist
             (- pl:ooff-dist)
          )
        )
      )
      (vla-endundomark adoc)
      (initget "Д Н _Y N")
      (if (not (setq isdel (getkword "\nУдалить исходные примитивы [Да/Нет] <Да>: ")))
        (setq isdel "Y")
      )
      (if (= isdel "Y")
        (progn (vla-startundomark adoc) (vla-erase asel) (vla-endundomark adoc))
      )
    )
  )
  (princ)
)
P.S. Проверка на лицензионном локализованном 2007-ом АКАДе проблему не выявила.
Alaspher вне форума  
 
Автор темы   Непрочитано 22.06.2007, 10:11
#15
dextron3

проектировшик
 
Регистрация: 01.01.2007
СССР
Сообщений: 5,143


Alaspher

Посмотри когда я первый раз работает а второй раз выдает такое как будто что то не то:

Command: _appload ooff3.lsp successfully loaded.
Command: ooff3
Select objects: Specify opposite corner: 3 found
Select objects:
Command:
Направление офсета [Внутрь/Наружу] <Внутрь>:
Укажи дистанцию <100>:
Удалить исходные примитивы [Да/Нет] <Да>:
Command:
Command: ooff3
; error: Automation Error. Calling method AddItems of interface
IAcadSelectionSet failed


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

еще раз просмотри проблему с предворительным выделением, хотя можно и так работать но всетаки
__________________
инженер проектировшик с опттом программа авто гад образование высшие
dextron3 вне форума  
 
Непрочитано 22.06.2007, 11:04
#16
Alaspher


 
Регистрация: 11.10.2004
e•burg
Сообщений: 755


Возможно, очередной косяк в реализации работы с активным набором (это внутрянка АКАДа - не починиить). Попробуй такой код:
Код:
[Выделить все]
(vl-load-com)
(defun c:ooff3 (/               adoc            pl:is-lwpoly-clock
                pl:obj-filter-select-manual     locs            asel            isclock
                isint           lays            isdel           tmp             ssel
               )
  (defun pl:is-lwpoly-clock (lwpl / pnts angl)
    (setq pnts (mapcar (function cdr)
                       (vl-remove-if-not (function (lambda (a) (= (car a) 10))) (entget lwpl))
               )
          angl (mapcar (function angle) (cons (last pnts) pnts) pnts)
    )
    (minusp (apply (function +)
                   (mapcar (function (lambda (b)
                                       (cond ((< (abs b) pi) b)
                                             ((minusp b) (+ (* 2 pi) b))
                                             (t (+ (* -2 pi) b))
                                       )
                                     )
                           )
                           (mapcar (function -) angl (cons (last angl) angl))
                   )
            )
    )
  )
  (defun pl:obj-filter-select-manual (sel filter)
    (vla-selectonscreen
      sel
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbinteger (cons 1 (length filter)))
        (mapcar (function car) filter)
      )
      (vlax-safearray-fill
        (vlax-make-safearray vlax-vbvariant (cons 1 (length filter)))
        (mapcar (function cdr) filter)
      )
    )
  )
  (setq adoc (vla-get-activedocument (vlax-get-acad-object))
        lays (vla-get-layers adoc)
        ssel (vla-get-selectionsets adoc)
  )
  (if (vl-catch-all-error-p
        (setq asel (vl-catch-all-apply (function vla-item) (list ssel "pl:ooff-sel")))
      )
    (setq asel (vla-add (vla-get-selectionsets adoc) "pl:ooff-sel"))
  )
  (vla-clear asel)
  (pl:obj-filter-select-manual asel '((0 . "LWPOLYLINE")))
  (vlax-for i asel
    (if (= :vlax-true (vla-get-lock (vla-item lays (vla-get-layer i))))
      (setq locs (cons i locs))
    )
  )
  (if locs
    (vla-removeitems
      asel
      (vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length locs)))) locs)
    )
  )
  (if (zerop (vla-get-count asel))
    (princ "\nНе выбрано полилиний на незаблокированных слоях.")
    (progn
      (initget "В Н _I O")
      (if (not (setq isint (getkword "\nНаправление офсета [Внутрь/Наружу] <Внутрь>: ")))
        (setq isint "I")
      )
      (if (/= (type pl:ooff-dist) 'REAL)
        (setq pl:ooff-dist 100.0)
      )
      (initget 6)
      (if (setq tmp (getdist (strcat "\nУкажи дистанцию <" (rtos pl:ooff-dist) ">: ")))
        (setq pl:ooff-dist tmp)
      )
      (vla-startundomark adoc)
      (vlax-for i asel
        (vla-offset
          i
          (if
            (or (and (setq isclock (pl:is-lwpoly-clock (vlax-vla-object->ename i))) (= isint "I"))
                (and (/= isint "I") (not isclock))
            )
             pl:ooff-dist
             (- pl:ooff-dist)
          )
        )
      )
      (vla-endundomark adoc)
      (initget "Д Н _Y N")
      (if (not (setq isdel (getkword "\nУдалить исходные примитивы [Да/Нет] <Да>: ")))
        (setq isdel "Y")
      )
      (if (= isdel "Y")
        (progn (vla-startundomark adoc) (vla-erase asel) (vla-endundomark adoc))
      )
    )
  )
  (princ)
)
Если полегчает, то я - прав.
Alaspher вне форума  
 
Непрочитано 22.06.2007, 11:13
#17
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Чуть оффтопа:
> Alaspher: У меня пару раз было на Windows XP +SP2 (без обновлений), AutoCAD 2007 + SP1 (либо AutoCAD 2008), что строка вида
Код:
[Выделить все]
(vlax-make-safearray vlax-vbinteger (cons 1 (length filter)))
пару раз сводила с ума лисп - он просто не проходил по элементам данных. С чем связано - не знаю, но замена на
Код:
[Выделить все]
(vlax-make-safearray vlax-vbinteger (cons 0 (1- (length filter))))
проблему, как правило, решало. Похоже, иногда нижняя граница массива передается как 0, несмотря на прямое указание использовать 1. Ну это так, лирика...
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 22.06.2007, 11:19
#18
Alaspher


 
Регистрация: 11.10.2004
e•burg
Сообщений: 755


Цитата:
Сообщение от Кулик Алексей aka kpblc
Чуть оффтопа:
> Alaspher: У меня пару раз было на Windows XP +SP2 (без обновлений), AutoCAD 2007 + SP1 (либо AutoCAD 2008), что строка вида
Код:
[Выделить все]
(vlax-make-safearray vlax-vbinteger (cons 1 (length filter)))
пару раз сводила с ума лисп - он просто не проходил по элементам данных. С чем связано - не знаю, но замена на
Код:
[Выделить все]
(vlax-make-safearray vlax-vbinteger (cons 0 (1- (length filter))))
проблему, как правило, решало. Похоже, иногда нижняя граница массива передается как 0, несмотря на прямое указание использовать 1. Ну это так, лирика...
Ты совершенно прав - один из таких случаев, как раз в моём коде учтён.
Alaspher вне форума  
 
Непрочитано 22.06.2007, 11:32
#19
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 39,787


Сорри, конечно, но:
Код:
[Выделить все]
(defun pl:obj-filter-select-manual (sel filter)
  (vla-selectonscreen
    sel
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbinteger (cons 1 (length filter)))
      (mapcar (function car) filter)
      ) ;_ end of vlax-safearray-fill
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbvariant (cons 1 (length filter)))
      (mapcar (function cdr) filter)
      ) ;_ end of vlax-safearray-fill
    ) ;_ end of vla-selectonscreen
  ) ;_ end of defun
Я б написал:
Код:
[Выделить все]
(defun pl:obj-filter-select-manual (sel filter)
  (vla-selectonscreen
    sel
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbinteger (cons 0 (1- (length filter))))
      (mapcar (function car) filter)
      ) ;_ end of vlax-safearray-fill
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbvariant (cons 0 (1- (length filter))))
      (mapcar (function cdr) filter)
      ) ;_ end of vlax-safearray-fill
    ) ;_ end of vla-selectonscreen
  ) ;_ end of defun
Вполне возможно, что это лишнее. Но "береженого и бог бережет",- сказала монашка и далее по тексту.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 22.06.2007, 12:15
#20
Alaspher


 
Регистрация: 11.10.2004
e•burg
Сообщений: 755


Цитата:
Сообщение от Кулик Алексей aka kpblc
Сорри, конечно, но:
Код:
[Выделить все]
(defun pl:obj-filter-select-manual (sel filter)
  (vla-selectonscreen
    sel
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbinteger (cons 1 (length filter)))
      (mapcar (function car) filter)
      ) ;_ end of vlax-safearray-fill
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbvariant (cons 1 (length filter)))
      (mapcar (function cdr) filter)
      ) ;_ end of vlax-safearray-fill
    ) ;_ end of vla-selectonscreen
  ) ;_ end of defun
Я б написал:
Код:
[Выделить все]
(defun pl:obj-filter-select-manual (sel filter)
  (vla-selectonscreen
    sel
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbinteger (cons 0 (1- (length filter))))
      (mapcar (function car) filter)
      ) ;_ end of vlax-safearray-fill
    (vlax-safearray-fill
      (vlax-make-safearray vlax-vbvariant (cons 0 (1- (length filter))))
      (mapcar (function cdr) filter)
      ) ;_ end of vlax-safearray-fill
    ) ;_ end of vla-selectonscreen
  ) ;_ end of defun
Вполне возможно, что это лишнее. Но "береженого и бог бережет",- сказала монашка и далее по тексту.
Ну, вреда не будет, так что - может и имеет смысл.
Alaspher вне форума  
Закрытая тема
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > Нужен лисп (super offset)

Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

Расширенный поиск