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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > почему не работает lisp

почему не работает lisp

Ответ
Поиск в этой теме
Непрочитано 27.05.2011, 07:14 #1
почему не работает lisp
Jonas
 
конструктор машиностроитель
 
Новосибирск
Регистрация: 14.05.2007
Сообщений: 893

Наверно с Акада 2000 пользуюсь лиспом для выдавливание труб по троекториям.
Сейчас Акад 2011, и лисп работать не хочет, верней строит только внешний цилиндр.

Уважаемые специалисты, посмотрите, может можно что то подправить?

Код:
[Выделить все]
 ; ==================================================================== ;;
;;                                                                      ;;
;;  XTUBE.LSP - Fast 3D-pipe extrude.                                   ;;
;;                                                                      ;;
;; ==================================================================== ;;
;;                                                                      ;;
;;  Command(s) to call: XTUBE                                           ;;
;;                                                                      ;;
;;  Select Lines, Polylines or Arcs, specify external and               ;;
;;  internal pipe diameter and press Enter. The program will            ;;
;;  extrude pipes. You can erase path lines after it.                   ;;
;;                                                                      ;;
;; ==================================================================== ;;
;;                                                                      ;;
;;  THIS PROGRAM AND PARTS OF IT MAY REPRODUCED BY ANY METHOD ON ANY    ;;
;;  MEDIUM FOR ANY REASON. YOU CAN USE OR MODIFY THIS PROGRAM OR        ;;
;;  PARTS OF IT ABSOLUTELY FREE.                                        ;;
;;                                                                      ;;
;;  THIS PROGRAM PROVIDES 'AS IS' WITH ALL FAULTS AND SPECIFICALLY      ;;
;;  DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY OR FITNESS        ;;
;;  FOR A PARTICULAR USE.                                               ;;
;;                                                                      ;;
;; ==================================================================== ;;
;;                                                                      ;;
;;  V1.2, 17 June, 2005, Riga, Latvia                                   ;;
;;  © Aleksandr Smirnov (ASMI)                                          ;;
;;  For AutoCAD 2000 - 2008 (isn't tested in a next versions)           ;;
;;                                                                      ;;
;;                             http://www.asmitools.com                 ;;
;;                                                                      ;;
;; ==================================================================== ;;

(defun c:xtube(/ 3DPOS ACTDOC ACTLAY ACTSP BASELINE 
                 BASESET DICOUNT DIVDID EXCIR EXENT 
                 EXTUBE INCIR INENT INTUBE LAYST 
                 OBJTYPE OLDECHO oldWidth oldHeight 
                 STARTPT XORD YORD ZORD DELFLAG *ERROR*)
  
  (vl-load-com) 

  (defun *error* (msg) 
    (vla-put-Lock actLay laySt) 
    (setvar "CMDECHO" oldEcho) 
    (vla-EndUndoMark actDoc) 
    (princ) 
    ); end of *error* 

  (if(not tube:Width)(setq tube:Width 40.0)) 
  (if(not tube:Height)(setq tube:Height 37.0)) 
  (setq actDoc 
    (vla-get-ActiveDocument 
      (vlax-get-Acad-object)) 
   actLay(vla-get-ActiveLayer actDoc) 
        oldWidth tube:Width 
   oldHeight tube:Height 
        oldEcho(getvar "CMDECHO") 
   ); end setq 
  (vla-StartUndoMark actDoc) 
  (setvar "CMDECHO" 0) 
  (if(= 0(vla-get-ActiveSpace actDoc)) 
    (setq actSp(vla-get-PaperSpace actDoc)) 
    (setq actSp(vla-get-ModelSpace actDoc)) 
    ); end if 
  (setq laySt(vla-get-Lock actLay)) 
  (vla-put-Lock actLay :vlax-false) 
  (setq tube:Width 
    (getreal 
      (strcat 
        "\nSpecify external diameter <"(rtos tube:Width)">: ")) 
       tube:Height 
    (getreal 
      (strcat 
        "\nSpecify internal diameter <"(rtos tube:Height)">: ")) 
   ); end setq 
  (if(null tube:Height)(setq tube:Height oldHeight)) 
  (if(null tube:Width)(setq tube:Width oldWidth)) 
  (if(< tube:Height tube:Width) 
    (progn 
  (princ "\n<<< Select objects to extrude and press Enter >>>") 
  (if 
    (setq baseSet 
      (ssget '((-4 . "<OR")(0 . "*LINE")(0 . "CIRCLE") 
           (0 . "ARC")(0 . "ELLIPSE")(-4 . "OR>") 
           (-4 . "<NOT")(-4 . "<OR")(0 . "SPLINE") 
                (0 . "MLINE")(-4 . "OR>")(-4 . "NOT>")))) 
    (progn 
      (setq baseSet(vl-remove-if 'listp 
                              (mapcar 
            'cadr 
            (ssnamex baseSet)))) 
      (foreach pathEnt baseSet 
      (setq baseLine 
        (vlax-ename->vla-object pathEnt) 
            objType(vla-get-ObjectName baseLine) 
            startPt(vlax-curve-getStartPoint baseLine) 
            3dPos 
        (vlax-curve-getFirstDeriv baseLine 
          (vlax-curve-getParamAtPoint baseLine startPt)) 
           diCount(strlen 
            (itoa 
         (apply 'max 
          (mapcar 'abs 
           (mapcar 'fix startPt))))) 
           divDid "1" 
       ); end setq
	(repeat diCount 
          (setq divDid(strcat divDid "0")) 
        ); end repeat 
         (setq divDid(atoi divDid)) 
         (if(/= 0.0(car 3dPos)) 
           (setq XOrd(/(car 3dPos)divDid)) 
           (setq XOrd (car 3dPos)) 
         ); end if 
         (if(/= 0.0(cadr 3dPos)) 
           (setq YOrd(/(cadr 3dPos)divDid)) 
           (setq YOrd (cadr 3dPos)) 
         ); end if 
        (if(/= 0.0(nth 2 3dPos)) 
           (setq ZOrd(/(nth 2 3dPos)divDid)) 
           (setq ZOrd (nth 2 3dPos)) 
         ); end if 
       (setq 3dPos(list XOrd YOrd ZOrd)
             exCir(vla-addCircle actSp 
                     (vlax-3d-Point startPt) 
                       (/ tube:Width 2)) 
             inCir(vla-addCircle actSp 
                     (vlax-3d-Point startPt) 
                        (/ tube:Height 2)) 
             ); end setq 
      (vla-put-Normal exCir(vlax-3D-point 3dPos)) 
      (vla-put-Normal inCir(vlax-3D-point 3dPos)) 
      (setq exEnt(vlax-vla-object->ename exCir) 
            inEnt(vlax-vla-object->ename inCir) 
            ); end setq 
  (command "_.extrude" exEnt "" "_p" pathEnt) 
  (setq exTube(entlast)) 
  (command "_.extrude" inEnt "" "_p" pathEnt) 
  (setq inTube(entlast)) 
  (command "_subtract" exTube "" inTube "") 
  (command "_.erase" exEnt "") 
  (command "_.erase" inEnt "") 
   ); end foreach
   (initget "Yes No") 
      (setq delFlag 
          (getkword "\nDelete extrude path(s)? [Yes/No] <No>: ")) 
      (if(null delFlag)(setq delFlag "No")) 
      (if(= "Yes" delFlag)
	(foreach pathEnt baseSet
           (vla-delete(vlax-ename->vla-object pathEnt))
	 ); end foreach
       ); end if 
      (vla-put-Lock actLay laySt) 
      (setvar "CMDECHO" oldEcho) 
       ); end progn 
      ); end if 
     ); end progn 
    (princ "\nInternal diameter more or equal external diameter! ") 
    ); end if 
  (vla-EndUndoMark actDoc) 
    (princ) 
); end  of c:xtube

(princ "\n[Info] http:\\\\www.AsmiTools.com [Info]")
(princ "\n[Info] Type XPIPE for extrude 3D-pipes. [Info]")
;
Просмотров: 4005
 
Непрочитано 30.05.2011, 10:38
#2
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Описание скудновато и проверить работу не на чем (нет чертежа с исходными объектами).
Наверное, изменилась работа команд extrude или subtract в 2011 версии. Может будет достаточно в строке
Код:
[Выделить все]
(command "_subtract" exTube "" inTube "")
точку поставить между _ и subtract?:
Код:
[Выделить все]
 (command "_.subtract" exTube "" inTube "")
Do$ вне форума  
 
Автор темы   Непрочитано 30.05.2011, 11:34
#3
Jonas

конструктор машиностроитель
 
Регистрация: 14.05.2007
Новосибирск
Сообщений: 893


Цитата:
Сообщение от Do$ Посмотреть сообщение
писание скудновато и проверить работу не на чем (нет чертежа с исходными объектами).
Исходными объектами являются линии.
Точка не помогла.
По диалогу отрабатывается вся программа:
-запрашивает внешний и внутренний диаметр,
- предлагает выбрать линии,
- подтверждает выбор,
- запрашивает удалить ли осевые линии но не зависимо от выбора удаляет.
В результате строит только по внешнему диаметру.
Jonas вне форума  
 
Непрочитано 30.05.2011, 11:49
#4
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


В 2010 версии программа работает. Что изменилось в 2011 версии - понятия не имею
Do$ вне форума  
 
Автор темы   Непрочитано 30.05.2011, 11:56
#5
Jonas

конструктор машиностроитель
 
Регистрация: 14.05.2007
Новосибирск
Сообщений: 893


И у меня в 2010 работало.
Jonas вне форума  
 
Непрочитано 30.05.2011, 14:49
#6
Oliver_88

"ценный кадр"
 
Регистрация: 02.12.2010
Сообщений: 115
<phrase 1=


Попробуй в ком.строке ввести DELOBJ на запрос нового значения введи 0. И тестируй. Может быть заработает.
Oliver_88 вне форума  
 
Непрочитано 30.05.2011, 17:09
#7
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


А вот так если:
Код:
[Выделить все]
 ;; ==================================================================== ;;
;;                                                                      ;;
;;  XTUBE.LSP - Fast 3D-pipe extrude.                                   ;;
;;                                                                      ;;
;; ==================================================================== ;;
;;                                                                      ;;
;;  Command(s) to call: XTUBE                                           ;;
;;                                                                      ;;
;;  Select Lines, Polylines or Arcs, specify external and               ;;
;;  internal pipe diameter and press Enter. The program will            ;;
;;  extrude pipes. You can erase path lines after it.                   ;;
;;                                                                      ;;
;; ==================================================================== ;;
;;                                                                      ;;
;;  THIS PROGRAM AND PARTS OF IT MAY REPRODUCED BY ANY METHOD ON ANY    ;;
;;  MEDIUM FOR ANY REASON. YOU CAN USE OR MODIFY THIS PROGRAM OR        ;;
;;  PARTS OF IT ABSOLUTELY FREE.                                        ;;
;;                                                                      ;;
;;  THIS PROGRAM PROVIDES 'AS IS' WITH ALL FAULTS AND SPECIFICALLY      ;;
;;  DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY OR FITNESS        ;;
;;  FOR A PARTICULAR USE.                                               ;;
;;                                                                      ;;
;; ==================================================================== ;;
;;                                                                      ;;
;;  V1.2, 17 June, 2005, Riga, Latvia                                   ;;
;;  © Aleksandr Smirnov (ASMI)                                          ;;
;;  For AutoCAD 2000 - 2008 (isn't tested in a next versions)           ;;
;;                                                                      ;;
;;                             http://www.asmitools.com                 ;;
;;                                                                      ;;
;; ==================================================================== ;;
;; Do$ modified 30.05.2011                                              ;;

(defun c:xtube (/
		3DPOS
		ACTDOC
		ACTLAY
		ACTSP
		BASELINE
		BASESET
		DICOUNT
		DIVDID
		EXCIR
		;;EXTENT
		EXTUBE
		INCIR
		;;INENT
		INTUBE
		LAYST
		OBJTYPE
		;;OLDECHO
		oldWidth
		oldHeight
		STARTPT
		XORD
		YORD
		ZORD
		DELFLAG
		VARREG
		*ERROR*
	       )

  (vl-load-com)

  (defun *error* (msg)
    (vla-put-Lock actLay laySt)
    ;;(setvar "CMDECHO" oldEcho)
    (vla-EndUndoMark actDoc)
    (princ)
  ) ;_ end of defun

  (if (not tube:Width)
    (setq tube:Width 40.0)
  ) ;_ end of if
  (if (not tube:Height)
    (setq tube:Height 37.0)
  ) ;_ end of if
  (setq	actDoc	  (vla-get-ActiveDocument
		    (vlax-get-Acad-object)
		  ) ;_ end of vla-get-ActiveDocument
	actLay	  (vla-get-ActiveLayer actDoc)
	oldWidth  tube:Width
	oldHeight tube:Height
		  ;;oldEcho	  (getvar "CMDECHO")
  ) ;_ end of setq
  (vla-StartUndoMark actDoc)
  ;;(setvar "CMDECHO" 0)
  (if (= 0 (vla-get-ActiveSpace actDoc))
    (setq actSp (vla-get-PaperSpace actDoc))
    (setq actSp (vla-get-ModelSpace actDoc))
  ) ;_ end of if
  (setq laySt (vla-get-Lock actLay))
  (vla-put-Lock actLay :vlax-false)
  (setq	tube:Width  (getreal
		      (strcat
			"\nSpecify external diameter <"
			(rtos tube:Width)
			">: "
		      ) ;_ end of strcat
		    ) ;_ end of getreal
	tube:Height (getreal
		      (strcat
			"\nSpecify internal diameter <"
			(rtos tube:Height)
			">: "
		      ) ;_ end of strcat
		    ) ;_ end of getreal
  ) ;_ end of setq
  (if (null tube:Height)
    (setq tube:Height oldHeight)
  ) ;_ end of if
  (if (null tube:Width)
    (setq tube:Width oldWidth)
  ) ;_ end of if
  (if (< tube:Height tube:Width)
    (progn
      (princ "\n<<< Select objects to extrude and press Enter >>>"
      ) ;_ end of princ
      (if
	(setq baseSet
	       (ssget '((-4 . "<OR")
			(0 . "*LINE")
			(0 . "CIRCLE")
			(0 . "ARC")
			(0 . "ELLIPSE")
			(-4 . "OR>")
			(-4 . "<NOT")
			(-4 . "<OR")
			(0 . "SPLINE")
			(0 . "MLINE")
			(-4 . "OR>")
			(-4 . "NOT>")
		       )
	       ) ;_ end of ssget
	) ;_ end of setq
	 (progn
	   (setq baseSet (vl-remove-if
			   'listp
			   (mapcar
			     'cadr
			     (ssnamex baseSet)
			   ) ;_ end of mapcar
			 ) ;_ end of vl-remove-if
	   ) ;_ end of setq
	   (foreach pathEnt baseSet
	     (setq baseLine
			    (vlax-ename->vla-object pathEnt)
		   objType  (vla-get-ObjectName baseLine)
		   startPt  (vlax-curve-getStartPoint baseLine)
		   3dPos
			    (vlax-curve-getFirstDeriv
			      baseLine
			      (vlax-curve-getParamAtPoint baseLine startPt)
			    ) ;_ end of vlax-curve-getFirstDeriv
		   diCount  (strlen
			      (itoa
				(apply 'max
				       (mapcar 'abs
					       (mapcar 'fix startPt)
				       ) ;_ end of mapcar
				) ;_ end of apply
			      ) ;_ end of itoa
			    ) ;_ end of strlen
		   divDid   "1"
	     ) ;_ end of setq
	     (repeat diCount
	       (setq divDid (strcat divDid "0"))
	     ) ;_ end of repeat
	     (setq divDid (atoi divDid))
	     (if (/= 0.0 (car 3dPos))
	       (setq XOrd (/ (car 3dPos) divDid))
	       (setq XOrd (car 3dPos))
	     ) ;_ end of if
	     (if (/= 0.0 (cadr 3dPos))
	       (setq YOrd (/ (cadr 3dPos) divDid))
	       (setq YOrd (cadr 3dPos))
	     ) ;_ end of if
	     (if (/= 0.0 (nth 2 3dPos))
	       (setq ZOrd (/ (nth 2 3dPos) divDid))
	       (setq ZOrd (nth 2 3dPos))
	     ) ;_ end of if
	     (setq 3dPos (list XOrd YOrd ZOrd)
		   exCir (vla-addCircle
			   actSp
			   (vlax-3d-Point startPt)
			   (/ tube:Width 2)
			 ) ;_ end of vla-addCircle
		   inCir (vla-addCircle
			   actSp
			   (vlax-3d-Point startPt)
			   (/ tube:Height 2)
			 ) ;_ end of vla-addCircle
	     ) ;_ end of setq
	     (vla-put-Normal exCir (vlax-3D-point 3dPos))
	     (vla-put-Normal inCir (vlax-3D-point 3dPos))
	     ;|
	     (setq exEnt (vlax-vla-object->ename exCir)
		   inEnt (vlax-vla-object->ename inCir)
	     ) ;_ end of setq
	     |;
	     (setq
	       varReg (vla-AddRegion
			actSp
			(vlax-safearray-fill
			  (vlax-make-safearray vlax-vbObject '(0 . 1))
			  (list inCir exCir)
			) ;_ end of vlax-safearray-fill
		      ) ;_ end of vla-AddRegion
	     ) ;_ end of setq
	     (mapcar 'vla-delete (list exCir inCir))
	     ((lambda (lst)
		(vla-Boolean (car lst) acSubtraction (last lst))
		(vla-AddExtrudedSolidAlongPath
		  actSp
		  (car lst)
		  (vlax-ename->vla-object pathEnt)
		) ;_ end of vla-AddExtrudedSolidAlongPath
		(vla-delete (car lst))
	      ) ;_ end of lambda
	       (vlax-safearray->list (vlax-variant-value varReg))
	     )
	     ;|	
  (command "_.extrude" exEnt "" "_p" pathEnt)	
  (setq exTube(entlast)) 
  (command "_.extrude" inEnt "" "_p" pathEnt) 
  (setq inTube(entlast)) 
  (command "_subtract" exTube "" inTube "") 
  (command "_.erase" exEnt "") 
  (command "_.erase" inEnt "")
  |;
	   ) ;_ end of foreach
	   (initget "Yes No")
	   (setq delFlag
		  (getkword "\nDelete extrude path(s)? [Yes/No] <No>: ")
	   ) ;_ end of setq
	   (if (null delFlag)
	     (setq delFlag "No")
	   ) ;_ end of if
	   (if (= "Yes" delFlag)
	     (foreach pathEnt baseSet
	       (vla-delete (vlax-ename->vla-object pathEnt))
	     ) ;_ end of foreach
	   ) ;_ end of if
	   (vla-put-Lock actLay laySt)
	   ;;(setvar "CMDECHO" oldEcho)
	 ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of progn
    (princ
      "\nInternal diameter more or equal external diameter! "
    ) ;_ end of princ
  ) ;_ end of if
  (vla-EndUndoMark actDoc)
  (princ)
) ;_ end of defun

(princ "\n[Info] Type XTUBE for extrude 3D-pipes. [Info]")
Вложения
Тип файла: lsp xtube.LSP (7.9 Кб, 89 просмотров)
Do$ вне форума  
 
Непрочитано 30.05.2011, 18:01
#8
Oliver_88

"ценный кадр"
 
Регистрация: 02.12.2010
Сообщений: 115
<phrase 1=


Да лучше кончено этот вариант. Вдруг будет пользоваться программой в которой значение DELOBJ должно быть не ноль.
Oliver_88 вне форума  
 
Автор темы   Непрочитано 31.05.2011, 05:10
#9
Jonas

конструктор машиностроитель
 
Регистрация: 14.05.2007
Новосибирск
Сообщений: 893


Цитата:
Сообщение от Oliver_88 Посмотреть сообщение
Попробуй в ком.строке ввести DELOBJ на запрос нового значения введи 0. И тестируй. Может быть заработает.
Работает при DELOBJ "0" и "1".
Цитата:
Сообщение от Do$ Посмотреть сообщение
А вот так если:
Да, работает.

Большое спасибо!

Еще раз хочу сказать что программа хороша не только для моделирования труб. Я, например, моделирую такие детали как втулка и шайба. Нарисовал нужной длины отрезок, затем XTUBE, ввел два диаметра, показал отрезок и готово.
Jonas вне форума  
 
Непрочитано 19.01.2012, 15:02
#10
semvb

Инженер-технолог
 
Регистрация: 18.11.2003
Мурманск
Сообщений: 180


Доброго времени суток. Спасибо за подправленный код программы для рисования труб, столкнулся с этой проблемой при переходе на 2012 ACAD. В комплекте с xtube шла программка xpipe, которая аналогично рисовала цилиндры. Может уважаемые Гуру подправят по аналогии и этот код, а то своих мозгов не хватает. (После отрисовки цилиндра - ось удалятся)
Файл прилагаю xpipe.LSP
semvb вне форума  
 
Непрочитано 25.01.2012, 16:23
#11
Do$

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,702
Отправить сообщение для Do$ с помощью Skype™


Ловите:
Код:
[Выделить все]
 
;; ==================================================================== ;;
;;                                                                      ;;
;;  XPIPE.LSP - Fast 3D-pipe extrude                                    ;;
;;                                                                      ;;
;; ==================================================================== ;;
;;                                                                      ;;
;;  Command(s) to call: XPIPE                                           ;;
;;                                                                      ;;
;;  Select Lines, Polylines or Arcs, specify pipe diameter and          ;;
;;  press Enter. The program will extrude pipes. You can                ;;
;;  erase path lines after it.                                          ;;
;;                                                                      ;;
;; ==================================================================== ;;
;;                                                                      ;;
;;  THIS PROGRAM AND PARTS OF IT MAY REPRODUCED BY ANY METHOD ON ANY    ;;
;;  MEDIUM FOR ANY REASON. YOU CAN USE OR MODIFY THIS PROGRAM OR        ;;
;;  PARTS OF IT ABSOLUTELY FREE.                                        ;;
;;                                                                      ;;
;;  THIS PROGRAM PROVIDES 'AS IS' WITH ALL FAULTS AND SPECIFICALLY      ;;
;;  DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY OR FITNESS        ;;
;;  FOR A PARTICULAR USE.                                               ;;
;;                                                                      ;;
;; ==================================================================== ;;
;;                                                                      ;;
;;  V1.4, 16 June, 2005, Riga, Latvia                                   ;;
;;  © Aleksandr Smirnov (ASMI)                                          ;;
;;  For AutoCAD 2000 - 2008 (isn't tested in a next versions)           ;;
;;                                                                      ;;
;;                             http://www.asmitools.com                 ;;
;;                                                                      ;;
;; ==================================================================== ;;

(defun c:xpipe (/
		actDoc
		actLay
		actSp
		baseLine
		baseSet
		;;cirEnt Do$ commented
		diCount
		divDid
		exCir
		laySt
		objType
		oldDia
		oldEcho
		startPt
		xOrd
		yOrd
		zOrd
		*error*
	       )

  (vl-load-com)

  (defun *error* (msg)
    (vla-put-Lock actLay laySt)
    (setvar "CMDECHO" oldEcho)
    (vla-EndUndoMark actDoc)
    (princ)
  )

  (if (not pipe:exDia)
    (setq pipe:exDia 40.0)
  ) ;_ end of if
  (setq	actDoc
		(vla-get-ActiveDocument
		  (vlax-get-Acad-object)
		) ;_ end of vla-get-ActiveDocument
	actLay	(vla-get-ActiveLayer actDoc)
	oldDia	pipe:exDia
	oldEcho	(getvar "CMDECHO")
  )
  (vla-StartUndoMark actDoc)
  (setvar "CMDECHO" 0)
  (if (= 0 (vla-get-ActiveSpace actDoc))
    (setq actSp (vla-get-PaperSpace actDoc))
    (setq actSp (vla-get-ModelSpace actDoc))
  )
  (setq laySt (vla-get-Lock actLay))
  (vla-put-Lock actLay :vlax-false)
  (setq	pipe:exDia
	 (getreal
	   (strcat
	     "\nУкажите диаметр цилинда <"
	     (rtos pipe:exDia)
	     ">: "
	   ) ;_ end of strcat
	 ) ;_ end of getreal
  ) ;_ end of setq
  (if (null pipe:exDia)
    (setq pipe:exDia oldDia)
  ) ;_ end of if
  (princ "\n<<< Выберите объекты оси и нажмите Enter  >>>")
  (if
    (setq baseSet
	   (ssget '((-4 . "<OR")
		    (0 . "*LINE")
		    (0 . "CIRCLE")
		    (0 . "ARC")
		    (0 . "ELLIPSE")
		    (-4 . "OR>")
		    (-4 . "<NOT")
		    (-4 . "<OR")
		    (0 . "SPLINE")
		    (0 . "MLINE")
		    (-4 . "OR>")
		    (-4 . "NOT>")
		   )
	   ) ;_ end of ssget
    ) ;_ end of setq
     (progn
       (setq baseSet (vl-remove-if
		       'listp
		       (mapcar 'cadr (ssnamex baseSet))
		     ) ;_ end of vl-remove-if
       ) ;_ end of setq
       (foreach	pathEnt	baseSet
	 (setq baseLine
			(vlax-ename->vla-object pathEnt)
	       objType	(vla-get-ObjectName baseLine)
	       startPt	(vlax-curve-getStartPoint baseLine)
	       3dPos
			(vlax-curve-getFirstDeriv
			  baseLine
			  (vlax-curve-getParamAtPoint baseLine startPt)
			) ;_ end of vlax-curve-getFirstDeriv
	       diCount	(strlen
			  (itoa
			    (apply 'max
				   (mapcar 'abs
					   (mapcar 'fix startPt)
				   ) ;_ end of mapcar
			    ) ;_ end of apply
			  ) ;_ end of itoa
			) ;_ end of strlen
	       divDid	"1"
	 )
	 (repeat diCount
	   (setq divDid (strcat divDid "0"))
	 )
	 (setq divDid (atoi divDid))
	 (if (/= 0.0 (car 3dPos))
	   (setq XOrd (/ (car 3dPos) divDid))
	   (setq XOrd (car 3dPos))
	 )
	 (if (/= 0.0 (cadr 3dPos))
	   (setq YOrd (/ (cadr 3dPos) divDid))
	   (setq YOrd (cadr 3dPos))
	 )
	 (if (/= 0.0 (nth 2 3dPos))
	   (setq ZOrd (/ (nth 2 3dPos) divDid))
	   (setq ZOrd (nth 2 3dPos))
	 )
	 (setq 3dPos (list XOrd YOrd ZOrd))
	 (setq exCir
		(vla-addCircle
		  actSp
		  (vlax-3d-Point startPt)
		  (/ pipe:exDia 2)
		) ;_ end of vla-addCircle
	 ) ;_ end of setq
	 (vla-put-Normal exCir (vlax-3D-point 3dPos))
	 ;;(setq cirEnt(vlax-vla-object->ename exCir)) Do$ commented


	 (setq ;;Do$ add (start)
	       varReg
		(vla-AddRegion
		  actSp
		  (vlax-safearray-fill
		    (vlax-make-safearray vlax-vbObject '(0 . 0))
		    (list exCir)
		  ) ;_ end of vlax-safearray-fill
		) ;_ end of vla-AddRegion
	 ) ;_ end of setq
	 (mapcar 'vla-delete (list exCir))
	 (vla-AddExtrudedSolidAlongPath
	   actSp
	   (setq objReg
		  (car
		    (vlax-safearray->list (vlax-variant-value varReg))
		  ) ;_ end of car
	   ) ;_ end of setq
	   (vlax-ename->vla-object pathEnt)
	 ) ;_ end of vla-AddExtrudedSolidAlongPath
	 (vla-delete objReg)
	 ;;Do$ add (end)
	 ;|Do$ commented
      (command "_.extrude" cirEnt "" "_p" pathEnt) 
      (command "_.erase" cirEnt "")
|;
       ) ;_ end of foreach
       (initget "Yes No")
       (setq delFlag
	      (getkword "\nУдалить ось? [Yes/No] <No>: ")
       ) ;_ end of setq
       (if (null delFlag)
	 (setq delFlag "No")
       ) ;_ end of if
       (if (= "Yes" delFlag)
	 (foreach pathEnt baseSet
	   (vla-delete (vlax-ename->vla-object pathEnt))
	 )
       )
       (vla-put-Lock actLay laySt)
       (setvar "CMDECHO" oldEcho)
       (vla-EndUndoMark actDoc)
     )
  )
  (princ)
)

(princ "\n[Info] http:\\\\www.AsmiTools.com [Info]")
(princ
  "\n[Info] Команда для рисования цилиндра xpipe. [Info]"
) ;_ end of princ
Вложения
Тип файла: lsp xpipe.LSP (6.6 Кб, 69 просмотров)

Последний раз редактировалось Do$, 11.09.2015 в 15:53.
Do$ вне форума  
 
Непрочитано 25.01.2012, 18:41
#12
semvb

Инженер-технолог
 
Регистрация: 18.11.2003
Мурманск
Сообщений: 180


Огромадное благодарствие!!!!!!
semvb вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > LISP > почему не работает lisp

CAD БИБЛИОТЕКА
Размещение рекламы
Опции темы Поиск в этой теме
Поиск в этой теме:

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
LISP для offset Positron LISP 19 02.01.2020 21:04
Работает ли VBA из MS Access (или VB6) application на 64-бит? Alex5556 Программирование 2 03.03.2010 20:53
Объясните почему такая разница в подобранной арматуре МишаИнженер Расчетные программы 14 26.02.2010 23:15
lisp для англ Autocad не работает для русск autocad Alegzander LISP 7 28.05.2007 14:54
Кто знает почему? Sleekka Программирование 4 26.05.2007 22:37