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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Express Tools Bugs ( Ошибки Express Tools )

Express Tools Bugs ( Ошибки Express Tools )

Ответ
Поиск в этой теме
Непрочитано 03.09.2008, 15:56
ExpressTools Bugs ( Ошибки ExpressTools )
VVA
 
Инженер LISP
 
Минск
Регистрация: 11.05.2005
Сообщений: 6,776

В моем арсенале набралось уже как минимум 3 исправленные ошибки Express Tools ( BURST, CLIPIT, TEXTMASK). BURST и CLIPIT были обнаружены по наводке Vova, TEXTMASK моими юзерами. По мере появления свободного времени опишу их все.
__________________
Как использовать код на Лиспе читаем здесь

Последний раз редактировалось VVA, 23.08.2010 в 18:11.
Просмотров: 85587
 
Непрочитано 02.10.2009, 13:54
#21
kshatriy


 
Регистрация: 06.08.2008
Сообщений: 30


Цитата:
Сообщение от Дима_ Посмотреть сообщение
p.s. При всавки этой функиии tcase работает правильно, но возможны проблеммы с другими лиспами.
в любом случае Спасибо! за помощь.
kshatriy вне форума  
 
Непрочитано 09.10.2009, 15:24
#22
kshatriy


 
Регистрация: 06.08.2008
Сообщений: 30


Цитата:
Сообщение от VVA Посмотреть сообщение
BURST (исправлена 03.09.2008).

Вводная: В блоке есть примитивы с типом линии "byblock". Блок расположен не на 0 слое и явно или через слой ему задан тип линии, отличный от "continuous"
Проблема: Если делать Burst таким блокам, то тип линии теряется, хотя в программе (burst.lsp) эта ситуация обрабатывается
Ошибка: В коде идет сравнение типа линии (группа 6) с "BYBLOCK", хотя в описании блока эта строка хранится как "ByBlock". Естественно условие никогда на выполнится.
Исправленная версия находится в файле bursfix.lsp. Можно переименовать в burst.lsp и заменить стандартный в папке Express Tools.
В файле burstfix.dwg находится пример.
Сделайте burst блокам ниже надписи BURST it and look at result сначала стандартным BURST из Express Tools, затем BURST из burstfix.lsp
и сравните результат.
Изменения в файле помечены как
;_Rem by VVA
;_Change by VVA

*** Добавлено 09.02.2009
Внес изменения. Выложено 2 файла
Файл burstfix.lsp - исправлена ошибка наследования примитивом с типом линии BYBLOCK типа линии блока, вес линий, проверка на vla-get-explodable (см #12)
Файл burstfix.dwg примеры.
Дана таблица сравнения работы команд Burst из Express Tools и BurstFix.
В файле burstfix.dwg одну строчку блоков взорвать Burst из Express Tools,
вторую Burst из BurstFix и сравнить с примером.
VVA: Результат теста AutoCAD 2009rus: в первом и во втором блоках по одной линии изменились и блок "Burstfix+Attr" не взорвался:
Код:
[Выделить все]
Команда: burst

Выберите объекты: найдено: 1

Выберите объекты:

|
неверный ассоциативный список: (nil)
Сможете исправить?
Вложения
Тип файла: rar burstfix.rar (58.3 Кб, 243 просмотров)
kshatriy вне форума  
 
Автор темы   Непрочитано 09.10.2009, 21:49
#23
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,776
Отправить сообщение для VVA с помощью ICQ Отправить сообщение для VVA с помощью Skype™


обновил #2
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 10.10.2009, 07:43
#24
kshatriy


 
Регистрация: 06.08.2008
Сообщений: 30


Цитата:
Сообщение от VVA Посмотреть сообщение
обновил #2
Спасибо!! все работает
kshatriy вне форума  
 
Автор темы   Непрочитано 18.02.2010, 11:34
#25
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,776
Отправить сообщение для VVA с помощью ICQ Отправить сообщение для VVA с помощью Skype™


Из этой темы: Помогите исправить программу под 2010 версию
Цитата:
Сообщение от Profan Посмотреть сообщение
Подчеркну, что в стандартной поставке AutoCAD программы exfillet никогда не было, эта программа была в отдельном самостоятельном сборнике, который можно было установить автономно на AutoCAD 2000, 2000i и 2002. Поэтому она никогда и не убиралась из Express Tools.
Команда EXFILLET
Код:
[Выделить все]
;;
;;;    adaptation for AutoCAD 2010 VVA (V.A.Azarko)
;;;    posted http://forum.dwg.ru/showthread.php?t=47047&page=3
;;;
;;;    EXFILLET.LSP -- Written by Paul Vine
;;;    Copyright © 1999 by Autodesk, Inc.
;;;
;;;    Your use of this software is governed by the terms and conditions of the
;;;    License Agreement you accepted prior to installation of this software.
;;;    Please note that pursuant to the License Agreement for this software,
;;;    "[c]opying of this computer program or its documentation except as
;;;    permitted by this License is copyright infringement under the laws of
;;;    your country.  If you copy this computer program without permission of
;;;    Autodesk, you are violating the law."
;;;
;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;;    UNINTERRUPTED OR ERROR FREE.
;;;
;;;    Use, duplication, or disclosure by the U.S. Government is subject to
;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;;    (Rights in Technical Data and Computer Software), as applicable.
;;;
;;;  ----------------------------------------------------------------
;;;     31 strings.
;;;  ----------------------------------------------------------------
;;;     Last Revision
;;;     Credits:  Inspired by the thread "Filleting two polyline segments" on
;;;           news://adesknews.autodesk.com/autode....customization
;;;          Thanks to whomever raised the issue and participants on the thread
;;;        including particularly:
;;;        David Garrigues and Ian White
;;;    Created by Paul Vine 7/10/98
;;;    Bug fixing ... 8/6/98
;;;    Last bug fix: 9/5/98
;;;    TAHOE work (4/1/99):
;;;     Changed concatenated string usage to acet-str-format
;;;     Changes error handler calls to acet-error-init instead of bns*
;;;
;;;     FIXES THE FOLLOWING PLINE/FILLET BUGS and WISHLIST items:
;;;     1. Filleting between anything BUT a line with a  pline.
;;;         This allows the user to FILLET arcs, circles, splines, ellipses, etc., with plines
;;;         however, only lines get added to the pline    -- STILL in 2000
;;;     2. Filleting individual segments in a LWPOLYLINE more than once (this is fixed in 2000)
;;;     3. Filleting between two different plines.    (still a problem in 2000)
;;;     4. Auto-repeats command until user hits enter.
;;;     5. Eliminates looping in "Select second object:" prompt.
;;;     6. POLYLINE option using a selection set.
;;;     7. Adds a joinmode setting to automatically join objects when feasible.
 
;;;    TO DO:
;;;     19. Honor standard selection set acquisition like C, CP, WP, etc.
 ;;;    20. Allow correct undo handling of trimmode?
 
 ;;;THIS VERSION HAS THE REVISED UNDO HANDLER.
 
 
(defun c:exfillet ( / option sTrim sRad iUndo sJoin);made this guy a global
   (acet-error-init
    (list
        (list "cmdecho" 0
            "highlight" 1
              "qaflags" 0
             "limcheck" 0
            "plinetype" 2
               "clayer" (getvar "clayer")
              "cecolor" (getvar "cecolor")
              "celtype" (getvar "celtype")
	    "pickstyle" 0
        )
       0     ;flag. True means use undo for error clean up.
       '(myerror)
     );list
    );acet-error-init
 
  (sssetfirst nil nil)
  (defun myerror ()
      (if (= (type option) 'LIST)
        (redraw (car option) 4)
      )
   ) ;defun myerror
 
 
    (setvar "errno" 7)
    (setq iUndo 0) ;setq
    (while  (= (getvar "errno") 7)
      (setvar "errno" 0)
      ;;;new code follows for status line...
      (cond
        ( (= (acet-exfillet-gettrim) 0)(setq sTrim "NOTRIM"))
        ( (= (acet-exfillet-gettrim) 1)(setq sTrim "TRIM"))
        ( (= (acet-exfillet-gettrim) 2)(setq sTrim "JOIN"))
      );cond
 ;(alert (strcat "iUndo = " (itoa iUndo)))
      (setq sRad (rtos (getvar "filletrad"))) ;setq
      (princ (acet-str-format "\nCurrent settings: Mode = %1, Radius = %2" sTrim sRad))
      ;(princ (strcat "\nCurrent settings: Mode = " sTrim ", Radius = " sRad ))
      (initget "Polyline Radius Trim Undo")
      (setq option (entsel "\nSelect first object or [Polyline/Radius/Trim/Undo]: "));
      (cond
        ((= (type option) 'LIST) (acet-exfillet-optUserPick option))
        ((= option "Polyline") (acet-exfillet-optPline))
        ((= option "Radius") (acet-exfillet-optRadius))
        ((= option "Trim") (acet-exfillet-optTrim))
        ((= option "Undo") (acet-exfillet-optUndo))
      );cond
 
    );while
  (acet-error-restore)
) ;defun c:exfillet
 
(defun acet-exfillet-optUndo ()   ; (alert (itoa iUndo))
    (if (> iUndo 0)
      (progn
        ;(command "_.undo" "1")
        (command "_.undo" "_B")
        (setq iUndo (1- iUndo)) ;setq
      );progn
      (princ "\nNothing to Undo.");else if the user never started, tell 'em we're at the beginning.
    );if
    (setvar "errno" 7)
);end INTERNAL UNDO
 
 
(defun acet-exfillet-optPline ( / ss i ent)
  (setq ss (ssget '(
                    (-4 . "<OR")
                      (0 . "LWPOLYLINE")          ;filter for 2d plines
                      (-4 . "<AND")               ;or heavy plines that
                        (0 . "POLYLINE")          ;are not pface meshes
                        (-4 . "<NOT")             ;polygon meshes or
                          (-4 . "&")              ;3dpolies
                          (70 . 88)
                        (-4 . "NOT>")
                      (-4 . "AND>")
                    (-4 . "OR>")
  )))  ;setq
  (if ss
    (progn
      ;(command "_.undo" "_be")
      (command "_.undo" "_m")
      (setq i 0) ;setq
      (repeat (sslength ss)
        (setq ent (ssname ss i)) ;setq
        (command "_.fillet" "_P" ent)  ;;this failed on 3dpolies
        (setq i (1+ i)) ;setq
      ) ;repeat
      ;(command "_.undo" "_end")
      (setq iUndo (1+ iUndo)) ;setq
     );progn
   );if
   (setvar "errno" 7)
 
) ;defun optPline
 
(defun acet-exfillet-optRadius ( / ans)
  (initget 4) ; 1 line fix for negative radius.
  (setq ans (getdist (acet-str-format "\nEnter fillet radius <%1>: " (getvar "filletrad") ))) ;setq
  ;(setq ans (getdist (strcat "\nEnter fillet radius <" (rtos (getvar "filletrad"))">: " ))) ;setq
  (if ans
    (progn
    (command "_.undo" "_M")
    (setvar "filletrad" ans)
    (setq iUndo (1+ iUndo)) ;setq
    );progn
   ) ;if
   (setvar "errno" 7)
);defun
 
(defun acet-exfillet-optUserpick ( option  / lsValid lsBugfix ent entType e2 ent2  bCoplanar
                                            ent2Type ss2 entlist ent2list bLayerUnLocked pickpt1 pickpt2
                                            Color Linetype)
  (if (not iUndo)
    (setq iUndo 0) ;setq
  ) ;if
  (setq lsValid (list "POLYLINE" "LWPOLYLINE" "LINE" "ARC" "ELLIPSE" "CIRCLE" "SPLINE" "RAY" "XLINE")) ;setq
  (setq lsBugfix (list "ARC" "ELLIPSE" "CIRCLE" "SPLINE" "RAY" "XLINE" "LINE")) ;setq          ARC IS THE ONLYTHING THAT
  (setq ent (car option)) ;setq                                        ^^^^^^^ is a bug fix for filleting fit- and spline-curved plines to lines
  (setq pickpt1 (osnap (cadr option ) "_nea")) ;setq
  (redraw ent 3)
  (setq entlist (entget ent)) ;setq
  (setq entType (cdr (assoc 0 entlist)) ;setq
         bLayerUnLocked (acet-layer-locked (cdr (assoc 8 entlist))) ;setq
         bCoplanar (acet-exfillet-bCoplanar ent));
 
  (if (and (member entType lsValid) (not bLayerUnLocked) bCoplanar )     ;if the first one is good, look at the second one.
    (progn
      (setq ent2type nil) ;setq
      (setq e2 T) ;setq
      (while (and e2 (or (= (getvar "errno") 7) (not (member ent2type lsValid))) )
        (setvar "errno" 0)
        (setq e2 (entsel "\nSelect second object: ")) ;setq
        (if e2
          (progn
            (setq ent2 (car e2)) ;setq
            (setq pickpt2 (osnap (cadr e2 ) "_nea"))
            (setq ent2list (entget ent2)) ;setq
            (setq ent2Type (cdr (assoc 0 ent2list)) ;setq
                 bLayerUnLocked (acet-layer-locked (cdr (assoc 8 ent2list))) ;setq
                 bCoplanar (acet-exfillet-bCoplanar ent2))
            (if (and (member ent2Type lsValid) (not bLayerUnLocked) bCoplanar)  ;here is where the second pick is valid and we can do our thing
              (progn
                (setvar "clayer" (cdr (assoc 8 entlist)))
                (setq Color (cdr (assoc 62 entlist))) ;setq
                (setq Linetype (cdr (assoc 6 entlist))) ;setq
                (if Color
                  (setvar "cecolor" (itoa Color))
                )
                (if Linetype
                  (setvar "celtype" Linetype)
                )
                (acet-exfillet-fillet)
              );progn
        ;else  if the second object was on a locked layer or was not a valid entity.
              (progn
                (cond
                  ( bLayerUnLocked  (princ "\nThe object is on a locked layer."))
                  ( (not bCoplanar) (princ "\nObject is not parallel to the current UCS."))
                  ((not (member ent2type lsValid)) (princ "\nRequires 2 lines, arcs, circles, plines, ellipses, splines, rays or xlines."))
                  (t "\nUnknown error.")
                );cond
                (setvar "errno" 7)   ;telks the loop to ask again.
              );progn
            ) ;if
          );progn
        );if
            ;(setvar "errno" 0)    ;;;0 breaks out of the loop.
      );while
    );progn
  ;;;else the the first entity was either on a locked layer or it was an invlid object....
    (cond
        ( bLayerUnLocked  (princ "\nThe object is on a locked layer."))
        ( (not bCoplanar) (princ "\nObject is not parallel to the current UCS."))
        ((not (member enttype lsValid)) (princ "\nRequires 2 lines, arcs, circles, plines, ellipses, splines, rays or xlines."))
        (t "\nUnknown error.")
    );cond
 
  ) ;if
  (setvar "errno" 7)
  (redraw ent 4)
 
) ;defun optUserpick
 
 
 
(defun  acet-exfillet-PlinetoCurve( ent ent2 pickpt1 pickpt2 ent2Type / ss    eLast entFillet lsWidthThick subentpt1 )
  ;(print pickpt1)
  ;(command "_.undo" "_be")
  (command "_.undo" "_m")
  (setq lsWidthThick (acet-exfillet-getwidth-thickness ent))
  (command "_.explode" ent )   ;;;ent is assumed to be the pline
  (setq ss (ssget "_P")) ;setq
  (setq eLast (entlast)) ;setq
  (setq subentpt1 (car (nentselp pickpt1))) ;setq
 
  (command "_.fillet" (list ent pickpt1)(list ent2 pickpt2))
 
  (if (not (wcmatch (getvar "cmdnames") "*FILLET*")) ;;if we succeded in filleting
    (progn
    (cond
      ;;;if nothing new was created and we have either an arc or a line and  trim mode is set to 2.
      ( (and (equal eLast (entlast)) (or (= ent2Type "ARC") (= ent2Type "LINE")) (= (acet-exfillet-gettrim) 2))
        (progn
          ;(command "_.ucs" "_ob" subentpt1 )
          (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick))
          (command "_.pedit" ent2 "_Y" "_W" (rtos (car lsWidthThick))  "_J" ent "" "_X")   ;;;then pedit join it all together
          ;(command "_.ucs" "_P")
          (command "_.erase" ss "")
        );progn
      );this condition
 
      ;;;if something was created and trimmode is set to join
       ( (and (not (equal eLast (entlast))) (or (= ent2Type "ARC") (= ent2Type "LINE")) (= (acet-exfillet-gettrim) 2))
          (progn
            (setq entFillet (entlast))
           ; (command "_.ucs" "_ob" subentpt1 )
            (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick))
            (command "_.pedit" entFillet "_Y" "_W" (rtos (car lsWidthThick)) "_J" ent ent2 "" "_X")   ;;;then pedit join it all together
           ; (command "_.ucs" "_p" )
            (command "_.erase" ss "")
          );progn
       )
    ;;;if something was created but the second entity is not joinable...
      ( (and (not (equal eLast (entlast))) (not (or (= ent2Type "ARC") (= ent2Type "LINE"))) (= (acet-exfillet-gettrim) 2))
          (progn
            (setq entFillet (entlast))
            ;(command "_.ucs" "_ob" subentpt1 )
            (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick))
            (command "_.pedit" entFillet "_Y" "_J" ent "" "_X")   ;;;then pedit join the fillet and the pline together.
            ;(command "_.ucs" "_p")
            (command "_.erase" ss "")
          );progn
       )
 
      ( t (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick)))
    );cond
 
    ;(command "_.undo" "_end")
    (setq iUndo (1+ iUndo)) ;setq
    (setvar "errno" 0)
   );progn
  ;;else the fillet failed....
    (progn
      (command nil)  ;;;force us out of the "select second object" prompt by hitting the 1st entity again.
      ;(command "_.undo" "2");;;this might need to be changed to an undo 3
      (command "_.undo" "_B")
      (setvar "errno" 7)  ;;;errno of 7 means loop it
    );progn
  );if
 
  nil
  ;(setq e2 nil) ;setq
) ;defun ()
 
(defun acet-exfillet-fillet ( )
 
(cond
  ;;let the special casing begin....
  ((and (wcmatch entType "*POLYLINE") (member  ent2Type lsBugfix))  ;if ent1 is pline and other is on bugfix list.
    (setq e2 (acet-exfillet-PlinetoCurve ent ent2 pickpt1 pickpt2 ent2Type) )
  )
 
  ((and (wcmatch ent2Type "*POLYLINE") (member  entType lsBugfix))    ;if ent2 is pline and other is on bugfix list
    (setq e2 (acet-exfillet-PlinetoCurve ent2 ent pickpt2 pickpt1 entType))
  )
 
  ((and (= entType "LWPOLYLINE") (equal ent ent2))  ;if it's two segments on the same lwpolyline...
    (progn
 ;          (alert "2 segments on lwpoly.")
      ;(command "_.undo" "_be")
      (command "_.undo" "_m")
      (command "_.convertpoly" "_H" ent "")
      (command "_.fillet" pickpt1 pickpt2)
      (if (not (wcmatch (getvar "cmdnames") "*FILLET*")) ;;if we succeded in filleting
        (progn
          (command "_.convertpoly" "_L" ent "")
          ;(command "_.undo" "_end")
          (setq iUndo (1+ iUndo)) ;setq
          (setq e2 nil) ;setq
          (setvar "errno" 0)    ;;means we succeeded and can break out of the loop
        );progn
      ;;else
        (progn
          (command nil)  ;;;force us out of the "select second object" prompt
          ;(command "_.undo" "1")        ; changed this line
          (command "_.undo" "_B")
          (command "_.convertpoly" "_L" ent "")            ;and this line to fix P1 AutoCAD bug.
          (setvar "errno" 7)  ;;;errno of 7 means something went wrong  on the second object prompt
        );progn
      );if
    );progn
  );this case
 
  ((and (wcmatch ent2Type "*POLYLINE") (wcmatch entType "*POLYLINE")(not (equal ent ent2)))    ;if they are both plines
    (acet-exfillet-PlinetoPline)
  );this case
 
  ( T
    (progn
      (command "_.fillet"  (list ent pickpt1)(list ent2 pickpt2))
      (if (not (wcmatch (getvar "cmdnames") "*FILLET*")) ;;if we succeded in filleting
        (progn
          (setq iUndo (1+ iUndo)) ;setq
          (setq e2 nil) ;setq
          (setvar "errno" 0)
        );progn
      ;else
        (progn
          (command nil)
          ;(command "_.undo" "1")
          (command "_.undo" "_B")
          (setvar "errno" 7)
        ) ;progn
      );if
    );progn
  );default -- just fillet 'em
);cond
 
);end defun
 
 
 
 
(defun acet-exfillet-getwidth-thickness (e /  elist rWidth this40 this41 SKIPLOOP rThickness  )
;;;Pass in the entity list for a pline and this will return a list of
;;;the widths of the various segments.   This is called by acet-exfillet-plinetopline
  (setq rWidth nil)
  (setq elist (entget e))
  (setq rThickness (cdr (assoc 39 elist))) ;setq
  (if (= rThickness nil)
    (setq rThickness 0.0) ;setq
  ) ;if
 
  (cond
    ((= (cdr(assoc 0 elist)) "LWPOLYLINE")
      (progn
      (setq rWidth (cdr (assoc 43  elist))) ;setq
      (if (= rWidth nil)
        (setq rWidth 0.0) ;setq
      ) ;if
      );progn
    )
    ((= (cdr(assoc 0 elist)) "POLYLINE")
      (progn
      (setq e (entnext e)) ;skip to the first vertex
      (setq elist (entget e))
      (setq this40 (assoc 40 elist)) ;setq
      (setq this41 (assoc 41 elist)) ;setq
      (setq rWidth (cdr this40 )) ;setq
      (if (not (= rWidth (cdr this41)))
        (progn
        (setq rWidth 0.0) ;setq
        (setq SKIPLOOP T) ;setq
        );progn
        (setq SKIPLOOP nil) ;setq
      ) ;if
      (while (and (= (cdr (assoc 0 elist)) "VERTEX") (= SKIPLOOP T))
       ;(print elist)(terpri)
        (if (or (not (= (cdr this40) rWidth)) (not (= (cdr this41) rWidth)))
          (progn
          (setq rWidth 0.0) ;setq
          (setq SKIPLOOP T) ;setq
          );progn
        ) ;if
        (setq e (entnext e))
        (setq elist (entget e))
        (setq this40 (assoc 40 elist)) ;setq
        (setq this41 (assoc 41 elist)) ;setq
      );while
      );progn
    );this cond
    (t (princ "\nMust pass a POLYLINE or LWPOLYLINE to (acet-exfillet-getwidth-thickness)."))
  );cond
  (list rWidth rThickness)
);defun
 
 
(defun acet-exfillet-optTrim ( / iTrim  sDefault ans )
 
  ;(command "_.undo" "_be")
  (command "_.undo" "_m")
  (setq iTrim (acet-exfillet-gettrim)) ;setq
 
  (cond
    ((= iTrim 0) (setq sDefault "No trim"))
    ((= iTrim 1) (setq sDefault "Trim"))
    ((= iTrim 2) (setq sDefault "Join"))
         ;setq
  ) ;if
  (initget "Join Trim Notrim")
  (setq ans (getkword (acet-str-format "\nEnter Trim mode option [Join/Trim/No trim] <%1>: " sDefault ))) ;setq
  ;(setq ans (getkword (strcat "\nEnter Trim mode option [Join/Trim/No trim] <" sDefault ">: " ))) ;setq
  (cond
    ((= ans "Join") (acet-exfillet-settrim 2))
    ((= ans "Trim") (acet-exfillet-settrim 1))
    ((= ans "Notrim") (acet-exfillet-settrim 0))
    ( t (acet-exfillet-settrim iTrim))
  );cond
  ;(command "_.undo" "_end") ;setq
  (setq iUndo (1+ iUndo)) ;setq
  (setvar "errno" 7)
) ;defun optTrim
 
 
 
(defun acet-exfillet-settrim ( iTrim / )
 
  (if (or (< iTrim 0)(> iTrim 2))
    (progn
      (princ "\nACET_TRIMMODE value must be in the range of 0 to 2.")
      nil          ;return nil if failed....
    );progn
  ;;else
    (progn
      (acet-setvar (list "ACET-TRIMMODE" iTrim 2))   ;set the bns variable in the registry
      (if (or (= iTrim 0)(= iTrim 1))       ;;if the value is 0 or 1
        (setvar "TRIMMODE" iTrim)           ;;set ACAD's the same else
        (setvar "TRIMMODE" 1)
       ;  (setvar "TRIMMODE" (getvar "TRIMMODE"))               ;; set it to 1 NO! do nothing
      ) ;if
      T   ;return true because all is well....
    );progn
  ) ;if
 
) ;defun acet-exfillet-settrim
 
(defun acet-exfillet-gettrim ( / iTrim)
 
  (setq iTrim (acet-getvar (list "ACET-TRIMMODE" 2))) ;setq
 
  (if (or
        (not iTrim)
        (and
          (or (= iTrim 0) (= iTrim 1))
          (not (= iTrim (getvar "TRIMMODE")))
        ) ;and
      );or
    ;(progn
      (setq iTrim (getvar "TRIMMODE"))
      ;(alert "\nACET-TRIMMODE and TRIMMODE were out of whack.")
      ;;;rewhack 'em
 
  ) ;if
  iTrim
) ;defun acet-exfillet-gettrim
 
(defun acet-exfillet-restorepline ( ss subentpt lsWidthThickness /    )
 ;;;Pass this function a selection set of lines and it will join them together and slap the width back on them.
  ;(command "_.ucs""_OB" subentpt)
  (command "_.pedit" subentpt "_Y" "_J" ss "" "_w")
  (if (> (car lsWidthThickness) 0.0000000)
    (command (rtos (car lsWidthThickness)) "_X")
    (command "0.0" "_X")
   );if
   (if (> (cadr lsWidthThickness) 0.00000000)
     (command "_.change" (entlast) "" "_P" "_T" (rtos (cadr lsWidthThickness))"")
   ) ;if
   ;(command "_.ucs" "_p")
  (entlast) ;return the ent name of the pline we just joined together,
);defun
 
(defun acet-exfillet-PlinetoPline  ( ;|ent ent2 pickpt1 pickpt2|; / lsWidthThick1 lsWidthThick2 eLast ss ss2 entFillet subentpt1 subentpt2 )
 
  ;    (alert "currently filleting two separate plines")
  ;(command "_.undo" "_be")
  (command "_.undo" "_m")
  (setq lsWidthThick2 (acet-exfillet-getwidth-thickness ent2) ) ;setq    Get the width info for each pline
  (command "_.explode" ent2  )                     ;explode
  (setq ss2 (ssget "_P")) ;setq                    ;stash it into a selection set
  ;;;adding new code to store width...
  (setq lsWidthThick1 (acet-exfillet-getwidth-thickness ent) ) ;setq
  (command "_.explode" ent  )
  (setq ss (ssget "_P")) ;setq
 
  (setq eLast (entlast)) ;setq
;(print pickpt1)
;(print pickpt2)
 
  (setq subentpt1 (car (nentselp pickpt1))) ;setq
  (setq subentpt2 (car (nentselp pickpt2)))
 
  (command "_.fillet"  (list subentpt1 pickpt1)(list subentpt2 pickpt2));;check to see if it succeeded (no "radius too large" errors)
 
 
  (if (not (wcmatch (getvar "cmdnames") "*FILLET*")) ;;if we succeded in filleting
    (progn
      (cond
        ;;if trimmode != notrim  and there is not a new segment to add.
        ((and (equal eLast (entlast)) (not(= (acet-exfillet-gettrim) 0)))
          (progn
            ;(command "_.ucs" "_ob" subentpt1 )
            (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick1))
            (setq ent2 (acet-exfillet-restorepline ss2 subentpt2 lsWidthThick2))
            (if (= (acet-exfillet-gettrim) 2)
              (command "_.pedit" ent  "_J" ent ent2 "" "_X")
            );if
            ;(command "_.ucs" "_p"  )
            (command "_.erase" ss ss2 "")
          );progn
        )
    ;;if trimmode != notrim and there is a new segment to add...
        ((and (not (equal eLast (entlast))) (not(= (acet-exfillet-gettrim) 0)))
          (progn
            (setq entFillet (entlast)) ;setq
            (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick1))
            (setq ent2 (acet-exfillet-restorepline ss2 subentpt2 lsWidthThick2))
            (if (= (acet-exfillet-gettrim)  2)
              (command "_.pedit" entFillet "_Y" "_W" (rtos (car lsWidthThick1)) "_J" ent ent2  "" "_X") ;apply width to fillet segment.
            );if
            (command "_.erase" ss ss2 "")
          );progn
        )
 
        (T
          (progn
            (setq ent (acet-exfillet-restorepline ss subentpt1 lsWidthThick1))
            (setq ent2 (acet-exfillet-restorepline ss2 subentpt2 lsWidthThick2))
          );progn
        )
 
      ) ;cond
 
      ;(command "_.undo" "_end")
      (setq iUndo (1+ iUndo)) ;setq
      (setq e2 nil) ;setq
      (setvar "errno" 0)
    );progn
  ;else
    (progn
      (command nil)  ;;;force us out of the "select second object" prompt
      ;(command "_.undo" "3")
      (command "_.undo" "_b")
      (setvar "errno" 7)  ;;;errno of 7 means something went wrong
    );progn
  );if
 
) ;defun acet-exfillet-PlinetoPline
 
(defun acet-Exfillet-bCoplanar ( e / elist v_ent v_ucs )
  ;;;takes an entity name and returns true if it lies in the plane of the current UCS.
  (setq elist (entget e)
       v_ent (cdr (assoc 210 elist))
      v_ucs (acet-geom-cross-product (getvar "ucsxdir") (getvar "ucsydir"))
  );setq
 
  (equal v_ent v_ucs 0.00000001)    ; return T if the entity is coplanar and nil if it is not.
 
) ;defun acet-exfillet-b-coplanar
(princ)
__________________
Как использовать код на Лиспе читаем здесь

Последний раз редактировалось VVA, 18.02.2010 в 12:59.
VVA вне форума  
 
Непрочитано 18.02.2010, 12:29
#26
Profan


 
Регистрация: 25.12.2005
Москва
Сообщений: 13,674


Только надо отметить, что в стандартной поставке Express Tools в одном дистрибутиве с AutoCAD этой программы не было и нет и придется ее прописывать вручную.
Profan вне форума  
 
Непрочитано 25.03.2010, 12:54
#27
human


 
Регистрация: 01.02.2008
Сообщений: 170


а у меня возникает ошибка в команде copym.
при копировании с равным шагом (measure) этот самый шаг часто не соблюдается. Т.е. получается один шаг где-то отличный от заданного , а остальные соответствуют. Последовательности не заметил - иногда нормально, иногда где-то один пролет изменяет расстояние. приходится постоянно менять точки начала отсчета и конца раскладки - помогает.
acad 2009 , но замечал и на 2007 такую же пакость.
human вне форума  
 
Автор темы   Непрочитано 25.03.2010, 13:44
#28
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,776
Отправить сообщение для VVA с помощью ICQ Отправить сообщение для VVA с помощью Skype™


human, Может быть это поможет Alternative copy
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 25.03.2010, 14:58
#29
human


 
Регистрация: 01.02.2008
Сообщений: 170


да, смотрел ту ветку.
но в экспрессе удобнее. выбираешь любой объект , начальную точку , шаг и конечную и он сам раскладывает. удобно для деревяшек, лестниц и при армировании. вот тока не всегда указанные интервалы выдает
human вне форума  
 
Непрочитано 25.03.2010, 19:46
#30
Vova

Engineer
 
Регистрация: 05.09.2003
New-York
Сообщений: 9,817


Здесь, кажется, есть работа для VVA. Чтобы не было искажений надо перед тем, как нажать заключительное Enter, отключить привязки (F3)
Vova вне форума  
 
Непрочитано 25.03.2010, 22:49
#31
Кулик Алексей aka kpblc
Moderator

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


В качестве первого приближения:
Код:
[Выделить все]
;;
;;  Copym.lsp - Multiple copy command with measure, divide and array capabilities.
;;                    
;;
;;  Copyright © 1999 by Autodesk, Inc.
;;
;;  Your use of this software is governed by the terms and conditions
;;  of the License Agreement you accepted prior to installation of this
;;  software.  Please note that pursuant to the License Agreement for this
;;  software, "[c]opying of this computer program or its documentation
;;  except as permitted by this License is copyright infringement under
;;  the laws of your country.  If you copy this computer program without
;;  permission of Autodesk, you are violating the law."
;;
;;  AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;  AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;  MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
;;  DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;  UNINTERRUPTED OR ERROR FREE.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:copym (/ ss p1 cmd snaptp ucshold)
  (acet-error-init
    (list (list	"cmdecho"   0		"snaptype"  0
		"snapmode"  nil		"gridmode"  nil
		"snapunit"  nil		"gridunit"  nil
		) ;_ end of list
 ;_ end of list
 ;_ end of list
					;list
	  0
	  '(progn
	    (acet-sysvar-set (list "cmdecho" 0))
	    (if
	     ss
	     (acet-ss-redraw ss 4)
	     )
	    (if
	     ucshold
	     (acet-ucs-set ucshold)
	     )
	    (acet-sysvar-restore)
	    (princ)
	    )				;progn
	  )				;list
    )					;acet-error-init
  (setq ucshold (acet-ucs-get nil))
  (if (setq ss (ssget))
    (progn
      (acet-ss-redraw ss 3)
      (setq p1 (getpoint "\nBase point: "))
      (acet-ss-redraw ss 4)
      (if p1
	(acet-copym ss p1)
	)				;if
      )					;progn then
    )					;if
  (acet-error-restore)
  )					;defun c:copym

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-copym (ss p1 / na p2 n d lst j p3)
  (setq p2 t)
  (setq n 0)
  (while p2
    (setq na (entlast))
    (if	(not lst)
      (setq lst (list (list ss p1)))
      )					;if
    (setvar "lastpoint" p1)
    (acet-ss-redraw ss 3)
    (initget 128 "Repeat Divide Measure Array Undo eXit")
    (setq p2
	   (acet-ss-drag-move
	     ss
	     p1
	     "\nSecond point or \n[Repeat (last)/Divide/Measure/Array (dynamic)/Undo] <exit>: "
	     nil
	     )				;acet-ss-drag-move 
	  )				;setq
    (acet-ss-redraw ss 4)
    (if	(= p2 "eXit")
      (setq p2 nil)
      )					;if
    (cond
      ((= p2 "Undo")
       (if (= n 0)
	 (princ "\nNothing to undo.")
	 (progn
	   (command "_.undo" "1")
	   (setq n   (- n 1)
		 lst (cdr lst)
		 ss  (car lst)
		 p1  (cadr ss)
		 ss  (car ss)
		 )			;setq
	   )				;progn else
	 )				;if
       )				;cond #1
      ((= p2 "Repeat")
       (if (= n 0)
	 (princ "\nNothing to repeat.")
	 (progn
	   (setq p2 (cadr (car lst))
		 p1 (cadr (cadr lst))
		 d  (list (- (car p2) (car p1))
			  (- (cadr p2) (cadr p1))
			  (- (caddr p2) (caddr p1))
			  )		;list
		 )			;setq
	   (command "_.copy" ss "" "_none" d "")
	   (setq n   (+ n 1)
		 ss  (acet-ss-new na)
		 p1  (list (+ (car p2) (car d))
			   (+ (cadr p2) (cadr d))
			   (+ (caddr p2) (caddr d))
			   )		;list
		 lst (cons (list ss p1) lst)
		 )			;setq
	   )				;progn else
	 )				;if
       )				;cond #2
      ((equal 'list (type p2))
       (command "_.copy" ss "" "_none" p1 "_none" p2)
       (setq n	 (+ n 1)
	     ss	 (acet-ss-new na)
	     p1	 p2
	     lst (cons (list ss p1) lst)
	     )				;setq
       )				;cond #3
      ((and (= "Divide" p2)
	    (setq p3 (getpoint p1 "\nSelect division ending point: "))
	    (progn
	      (initget 6)
	      (setq j (getint "\nNumber of copies: "))
	      )				;progn
	    )				;and
       (setq ss	 (acet-copym-divide ss p1 p3 j)
	     p1	 p3
	     lst (cons (list ss p1) lst)
	     n	 (+ n 1)
	     )				;setq
       )				;cond #4
      ((and (= "Measure" p2)
	    (setq p3 (getpoint p1 "\nSelect measure ending point: "))
	    (progn
	      (initget 6)
	      (setq d (getdist "\nDistance between copies: "))
	      )				;progn
	    )				;and
       (setq ss	 (acet-copym-measure ss p1 p3 d)
					;returns selset and base point
	     p1	 (cadr ss)
	     ss	 (car ss)
	     lst (cons (list ss p1) lst)
	     n	 (+ n 1)
	     )				;setq
       )				;cond #5
      ((= "Array" p2)
       (setq ss	 (acet-copym-array ss p1)
	     p1	 (cadr ss)
	     ss	 (car ss)
	     lst (cons (list ss p1) lst)
	     n	 (+ n 1)
	     )				;setq
       )				;cond #6
      (p2
       (princ "\nInvalid input.")
       )				;cond #7
      )					;cond close
    )					;while

  )					;defun acet-copym

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-copym-array	(ss p1 / a)
  (initget "Pick Measure Divide")
  (setq a (getkword "\nPick (dynamic)/Measure/Divide <Pick>: "))
  (cond
    ((or (not a)
	 (= a "Pick")
	 )				;or
     (setq a (acet-copym-array-dynamic ss p1))
     )					;cond #1
    ((= a "Measure")
     (setq a (acet-copym-array-measure ss p1))
     )					;cond #2
    ((= a "Divide")
     (setq a (acet-copym-array-divide ss p1))
     )					;cond #3
    )					;cond close
  a
  )					;defun acet-copym-array


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-copym-array-dynamic
       (ss p1 / snap grid snapu gridu p2 p3 p4 dx dy lst ss2 na a)

  (acet-undo-begin)
  (setq p2 (getangle p1 "\nSpecify angle <0>: "))
  (if p2
    (setq p2 (polar p1 p2 1.0))		;convert angle to a point
    (setq p2 (polar p1 0.0 1.0))	;use default of 0 and convert to point
    )					;if
  (setq	p3 (polar p1 (+ (angle p1 p2) (/ pi 2.0)) 1.0)
	p1 (trans p1 1 0)
	p2 (trans p2 1 0)
	p3 (trans p3 1 0)
	)				;setq
  (acet-ucs-cmd
    (list "_3p" (trans p1 0 1) (trans p2 0 1) (trans p3 0 1))
    ) ;_ end of acet-ucs-cmd
  (setq	p1 (trans p1 0 1)
	p2 (trans p2 0 1)
	p3 (trans p3 0 1)
	)				;setq

  (setq	p2  (acet-copym-getcorner
	      p1
	      "\nPick a corner point to establish COLUMN and ROW distances: "
	      t
	      ) ;_ end of acet-copym-getcorner
	dx  (- (car p2) (car p1))
	dy  (- (cadr p2) (cadr p1))
	lst (list p1)
	p4  t
	)				;setq 
  (acet-sysvar-set
    (list
      "snapunit"
      (list (abs dx) (abs dy))
      "gridunit"
      (list (abs dx) (abs dy))
      "snapmode"
      1
      "gridmode"
      1
      ) ;_ end of list
    )					;acet-sysvar-set

  (while p4
    (setvar "snapmode" 1)
    (setvar "gridmode" 1)
					;(setq p4 (getpoint p1 "\nPick location for array element or <enter> when done: "))
    (setq
      p4 (acet-ss-drag-move
	   ss
	   p1
	   "\nPick location for array element or <enter> when done: "
	   nil
	   )				;acet-ss-drag-move 
      )					;setq
    (cond
      ((not p4) t)			;cond #1
      ((member p4 lst)
       (princ "\n*invalid* You already picked that point!")
       )				;cond #2
      (t
       (setq na	 (entlast)
	     lst (cons p4 lst)
	     )				;setq
       (command "_.copy" ss "" "_none" p1 "_none" p4)
       )				;cond #3
      )					;cond close
    )					;while
  (if na
    (setq p1  (trans (getvar "lastpoint") 1 0)
	  ss2 (acet-ss-new na)
	  )				;setq
    (setq ss2 ss)			;setq else
    )					;if
  (acet-ucs-cmd (list "_prev"))
  (setq p1 (trans p1 0 1))

  (acet-sysvar-restore)
  (acet-undo-end)

  (list ss2 p1)
  )					;defun acet-copym-array-dynamic

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-copym-getcorner (p1 msg nozero / flag p2 na)
  (while (not flag)
    (setq na (entlast))
    (command "_.rectang" p1)
    (while (wcmatch (getvar "cmdnames") "*RECTANG*")
      (princ msg)
      (command pause)
      )					;while
    (setq p2 (getvar "lastpoint"))	;setq
    (if	(not (equal na (entlast)))
      (entdel (entlast))
      )					;if
    (cond
      ((not nozero)
       (setq flag t)
       )				;cond #1
      ((and (equal (car p1) (car p2) 0.00000001)
	    (equal (cadr p1) (cadr p2) 0.00000001)
	    )				;and
       (princ "\n*Points cannot be equal*")
       )				;cond #2
      ((= (car p1) (car p2))
       (princ "\n*X coords cannot be equal*")
       )				;cond #3
      ((= (cadr p1) (cadr p2))
       (princ "\n*Y coords cannot be equal*")
       )				;cond #4
      (t
       (setq flag t)
       )				;cond #5
      )					;cond close
    )					;while
  p2
  )					;defun acet-copym-getcorner

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-copym-array-measure	(ss   p1   /	snap grid snapu
				 gridu	   p2	p3   p4	  dx   dy
				 ss2  na   a	n    j	  k    m
				 x    y
				 )
  (acet-undo-begin)

  (setq p2 (getangle p1 "\nSpecify angle <0>: "))
  (if p2
    (setq p2 (polar p1 p2 1.0))		;convert angle to a point
    (setq p2 (polar p1 0.0 1.0))	;use default of 0 and convert to point
    )					;if
  (setq	p3 (polar p1 (+ (angle p1 p2) (/ pi 2.0)) 1.0)
	p1 (trans p1 1 0)
	p2 (trans p2 1 0)
	p3 (trans p3 1 0)
	)				;setq
  (acet-ucs-cmd
    (list "_3p" (trans p1 0 1) (trans p2 0 1) (trans p3 0 1))
    ) ;_ end of acet-ucs-cmd

  (setq	p1 (trans p1 0 1)
	p2 (acet-copym-getcorner
	     p1
	     "\nPick a corner point to establish ROW and COLUMN distances: "
	     t
	     ) ;_ end of acet-copym-getcorner
	dx (- (car p2) (car p1))
	dy (- (cadr p2) (cadr p1))
	p4 t
	)				;setq 
  (acet-sysvar-set
    (list
      "snapunit"
      (list (abs dx) (abs dy))
      "gridunit"
      (list (abs dx) (abs dy))
      "snapmode"
      1
      "gridmode"
      1
      ) ;_ end of list
    )					;acet-sysvar-set

  (setq	p2 (acet-copym-getcorner
	     p1
	     "\nOther corner for array fill: "
	     t
	     ) ;_ end of acet-copym-getcorner
	) ;_ end of setq
  (if (> (car p2) (car p1))
    (setq dx (abs dx))
    (setq dx (* -1.0 (abs dx)))
    )					;if
  (if (> (cadr p2) (cadr p1))
    (setq dy (abs dy))
    (setq dy (* -1.0 (abs dy)))
    )					;if
  (setq	k (/ (abs (- (car p2) (car p1)))
	     (abs dx)
	     ) ;_ end of /
	m (/ (abs (- (cadr p2) (cadr p1)))
	     (abs dy)
	     ) ;_ end of /
	k (+ 1 (atoi (rtos k 2 0)))
	m (+ 1 (atoi (rtos m 2 0)))
	)				;setq

  (setq n 0)
  (repeat m
    ;; rows
    (setq y (+ (cadr p1) (* dy n)))

    (setq j 0)
    (repeat k
      ;; columns
      (setq x (+ (car p1) (* dx j)))
      (setq na (entlast))
      (if (not (and (= n 0)
		    (= j 0)
		    )			;and
	       )			;not
	(command "_.copy"
		 ss
		 ""
		 "_none"
		 p1
		 "_none"
		 (list x y (caddr p1))
		 ) ;_ end of command
	)				;if
      (setq j (+ j 1))			;setq
      )					;repeat

    (setq n (+ n 1))
    )					;repeat
  (if na
    (setq p1  (trans (getvar "lastpoint") 1 0)
	  ss2 (acet-ss-new na)
	  )				;setq
    (setq ss2 ss)			;setq else
    )					;if
  (acet-ucs-cmd (list "_prev"))
  (setq p1 (trans p1 0 1))

  (acet-sysvar-restore)
  (acet-undo-end)

  (list ss2 p1)
  )					;defun acet-copym-array-measure

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-copym-array-divide
       (ss p1 / p2 dx dy ss2 na a n j k m x y p3)
  (acet-undo-begin)

  (setq p2 (getangle p1 "\nSpecify angle <0>: "))
  (if p2
    (setq p2 (polar p1 p2 1.0))		;convert angle to a point
    (setq p2 (polar p1 0.0 1.0))	;use default of 0 and convert to point
    )					;if
  (setq	p3 (polar p1 (+ (angle p1 p2) (/ pi 2.0)) 1.0)
	p1 (trans p1 1 0)
	p2 (trans p2 1 0)
	p3 (trans p3 1 0)
	)				;setq
  (acet-ucs-cmd
    (list "_3p" (trans p1 0 1) (trans p2 0 1) (trans p3 0 1))
    ) ;_ end of acet-ucs-cmd

  (setq	p1 (trans p1 0 1)
	p2 (acet-copym-getcorner
	     p1
	     "\nOther corner for array fill: "
	     nil
	     ) ;_ end of acet-copym-getcorner
	)				;setq

  (initget 6)
  (setq k (getint "\nEnter number of columns: "))
  (initget 6)
  (setq m (getint "\nEnter number of rows: "))
  (setq	dx (/ (- (car p2) (car p1)) k)
	dy (/ (- (cadr p2) (cadr p1)) m)
	)				;setq

  (setq n 0)
  (repeat m
    ;; rows
    (setq y (+ (cadr p1) (* dy n)))

    (setq j 0)
    (repeat k
      ;; columns
      (setq x (+ (car p1) (* dx j)))
      (setq na (entlast))
      (if (not (and (= n 0)
		    (= j 0)
		    )			;and
	       )			;not
	(command "_.copy"
		 ss
		 ""
		 "_none"
		 p1
		 "_none"
		 (list x y (caddr p1))
		 ) ;_ end of command
	)				;if
      (setq j (+ j 1))			;setq
      )					;repeat

    (setq n (+ n 1))
    )					;repeat
  (if na
    (setq p1  (trans (getvar "lastpoint") 1 0)
	  ss2 (acet-ss-new na)
	  )				;setq
    (setq ss2 ss)			;setq else
    )					;if
  (acet-ucs-cmd (list "_prev"))
  (setq p1 (trans p1 0 1))

  (acet-undo-end)

  (list ss2 p1)
  )					;defun acet-copym-array-divide


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
					;Takes a selection set, two points and the distance between 
					;consecutive copies.
					;Returns a list containing a selection set the most 
					;recent copy and a base point.
					;
(defun acet-copym-measure (ss p1 p3 d / j n na p2)

  (acet-undo-begin)
  (setq	j (fix (/ (distance p1 p3) d))
	n 1
	)				;setq
  (repeat j
    (setq p2 (polar p1 (angle p1 p3) (* d n))
	  na (entlast)
	  )				;setq
    (command "_.copy" ss "" "_none" p1 "_none" p2)
    (if	(= n j)
      (setq ss (acet-ss-new na))
      )					;if
    (setq n (+ n 1))
    )					;repeat 
  (acet-undo-end)
  (list ss p2)
  )					;defun acet-copym-measure

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
					;takes a selection set, two points and the number of copies to 
					;make of the selection between the two points.
					;returns a selection set the most recent copy
					;
(defun acet-copym-divide (ss p1 p3 j / d n na p2)

  (acet-undo-begin)
  (setq	d (/ (distance p1 p3) j)
	n 1
	)				;setq
  (repeat j
    (setq p2 (polar p1 (angle p1 p3) (* d n))
	  na (entlast)
	  )				;setq
    (command "_.copy" ss "" "_none" p1 "_none" p2)
    (if	(= n j)
      (setq ss (acet-ss-new na))
      )					;if
    (setq n (+ n 1))
    )					;repeat 
  (acet-undo-end)
  ss
  )					;defun acet-copym-divide
(princ)
Сохранить и заменить файл copym.lsp в каталоге расположения ЕТ
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 29.03.2010, 11:45
#32
human


 
Регистрация: 01.02.2008
Сообщений: 170


to
Кулик Алексей aka kpblc

Благодарю, вроде пока нормально работает.
human вне форума  
 
Непрочитано 09.06.2010, 10:00
#33
kakt00z

инженер-проектировщик КИПиА
 
Регистрация: 30.08.2008
Минск
Сообщений: 159


burst
еще надо бы заменить
(if (zerop (logand (cdr (assoc 70 AENT)) 1)) ...)
на
(if (or (zerop (logand (cdr (assoc 70 AENT)) 1)) ;_Change by VVA Attr fix 03.09.2008 Not hidden attribute
(zerop (logand (cdr (assoc 70 AENT)) 9)) ;_Add kakt00z 1.06.2010
) ...
если аттрибут скрытый+установленный
может есть и еще продолжения с вариантами аттрибутов, но я не сталкивался

PS: интересно, а что за нужда заставляет всех разбивать свои любимые, долго вымученные, годами продуманные блоки? неужели архив?
kakt00z вне форума  
 
Автор темы   Непрочитано 09.06.2010, 17:18
#34
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,776
Отправить сообщение для VVA с помощью ICQ Отправить сообщение для VVA с помощью Skype™


Исправил #2
Цитата:
Сообщение от kakt00z Посмотреть сообщение
интересно, а что за нужда заставляет всех разбивать свои любимые, долго вымученные, годами продуманные блоки?
При подготовке подосновы приходится разбивать чужие, через одно место сделанные блоки.
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 17.06.2010, 14:55
#35
Do$

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


Попробовал запустить OVERKILL в редакторе блоков в автокаде 2010 (в других версиях не пробовал). Работа программы прервалась ошибкой:
Код:
[Выделить все]
Command: overkill

Initializing...
Select objects: Specify opposite corner: 234 found

Select objects:

** _.UCS command not allowed in block editor. **
** _.UCS command not allowed in block editor. **
А также не вернулись в исходное состояние настройки переменных: "highlight" "ucsicon" "pickstyle" "osmode"... (Как выяснилось после довольно продолжительного копания на тему "а что это с автокадом случилось??") Так что, граждане, будьте бдительны
Do$ вне форума  
 
Непрочитано 24.06.2010, 13:56
#36
Makswell

Инженер-строитель
 
Регистрация: 15.08.2007
Киров
Сообщений: 2,252


Do$, я уже писал об этомв посте №9 в этой теме. Но напомнить не лишним будет конечно, т.к. проблема не решена. (хотя тупое решение можно сразу дать - обернуть код OVERKILL условием, проверяющим значение переменной BLOCKEDITOR. Если она равна 1, то ничего не выполнять, а выводить на экран только alert "в редакторе блоков OVERKILL не работает")
Makswell вне форума  
 
Автор темы   Непрочитано 24.06.2010, 16:53
#37
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,776
Отправить сообщение для VVA с помощью ICQ Отправить сообщение для VVA с помощью Skype™


Цитата:
Сообщение от Makswell Посмотреть сообщение
хотя тупое решение можно сразу дать - обернуть код OVERKILL условием, проверяющим значение переменной BLOCKEDITOR
Makswell, Наверное это правильное решение, т.к. в редакторе блоков может быть только одна система координат - самого блока.
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 20.07.2010, 10:46
#38
Psyakrev


 
Регистрация: 17.06.2010
Сообщений: 392


Autocad 2008 + sp1, русский, Express Tools не установлен.
Скачал burstfix из 2-го сообщения, загрузил, вбил burst, получил
Код:
[Выделить все]
; ошибка: no function definition: ACET-ERROR-INIT
Подскажите, как исправить.

ЗЫ ACET - AutoCad Express Tools? Если так, извините за глупый вопрос И так понятно, что нужно сделать.
Psyakrev вне форума  
 
Непрочитано 20.07.2010, 11:13
#39
Do$

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


Цитата:
Сообщение от Psyakrev Посмотреть сообщение
ЗЫ ACET - AutoCad Express Tools?

Цитата:
Сообщение от Psyakrev Посмотреть сообщение
И так понятно, что нужно сделать.
Do$ вне форума  
 
Непрочитано 20.07.2010, 11:37
#40
Eu

монтаж
 
Регистрация: 22.10.2006
Украина
Сообщений: 109


Хочу напомнить - суицид запрещен всеми существующими на настоящий момент религиями, в т.ч. и dwg/ru
__________________
Eu
Eu вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Express Tools Bugs ( Ошибки Express Tools )

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Express Tools Perezz!! AutoCAD 483 13.02.2015 10:57
Исчезновение части Express Tools SlayERR AutoCAD 4 09.10.2006 15:55
Express tools под Acad2005 AutoCAD 16 18.07.2004 01:58
express tools для autocad 2005 Савва AutoCAD 5 01.04.2004 09:52
Не загружается меню Express Tools. Mikhail AutoCAD 3 17.10.2003 14:16