dwg.ru forum rss xml
| Правила | Регистрация | Пользователи | Поиск | Сообщения за день | Все разделы прочитаны |  Справка по форуму |

Вернуться   Форум 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,542
Отправить сообщение для VVA с помощью ICQ Отправить сообщение для VVA с помощью Skype™

VVA вне форума Вставить имя

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

Последний раз редактировалось VVA, 23.08.2010 в 18:11.
Просмотров: 60006
 
Непрочитано 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 Кб, 224 просмотров)
kshatriy вне форума вставить имя Обратить внимание модератора на это сообщение  
 
Автор темы   Непрочитано 09.10.2009, 21:49
#23
VVA

Инженер LISP
 
Регистрация: 11.05.2005
Минск
Сообщений: 6,542
Отправить сообщение для 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,542
Отправить сообщение для 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,666


Только надо отметить, что в стандартной поставке 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,542
Отправить сообщение для 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,737


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

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


В качестве первого приближения:
Код:
[Выделить все]
;;
;;  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,542
Отправить сообщение для VVA с помощью ICQ Отправить сообщение для VVA с помощью Skype™


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

AutoCAD/Civil3D LISP/C#
 
Регистрация: 15.08.2008
Санкт-Петербург
Сообщений: 1,627
Отправить сообщение для 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,247


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

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


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


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


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,627
Отправить сообщение для 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

|| Главная || Каталог САПР || Тендеры || Публикации || Объявления || Биржа труда || Download || Галерея ||
|| Библиотека || Кунсткамера || Каталог предприятий || Контакты || Файлообменник || Блоги ||


Размещение рекламы