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

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

_JOIN1 до работка команды

Ответ
Поиск в этой теме
Непрочитано 24.09.2008, 13:40 #1
_JOIN1 до работка команды
DEM
 
YngIngKllr
 
СПб
Регистрация: 29.03.2005
Сообщений: 12,968

Требуется до работать команду _JOIN1 из сборника G-Tools
К сожалению данная команда не обрабатывает полилинии, а требуется объединение полилиний также как и отрезков.
При этом объединение должно происходить именно по выбраным сегментам полилинии.
Код:
[Выделить все]
;;;------------------------------------>JOIN1<-------------------------------------;;;
;;;                Команда объединения двух отрезков, дуг или текста               ;;;
;;;                            JOIN1.lsp Version 1.11                              ;;;
;;;                          Автор: Протасов Георгий                               ;;;
;;;Программа объединяет два отрезка или дуги, соединяя их наиболее удаленные точки,;;;
;;;замыкает дуги, объединяет текст                                                 ;;;
;;;--------------------------------------------------------------------------------;;;

(DEFUN JOIN1 ( / ed1 ed2
      cmdecho-save error-save
      REMBERALL ANGDISTANCE CLOSEELLIPSE CLOSEARC JOINLINES JOINELLIPSES JOINARCHES)
   (SETQ error-save *error*
      cmdecho-save (GETVAR "CMDECHO")
      );SETQ
 
   (DEFUN *error* (msg)
      (IF  error-save (SETQ *error* error-save))
      (IF msg (PRINC "\nВыполнение функции прервано "))
      ;; Восстановление значений системных переменных
      (SETVAR "CMDECHO" cmdecho-save)
      (IF ed1 (REDRAW (CDR (ASSOC -1 ed1)) 4))
      (PRINC)
      );DEFUN

   ;; Функция удаления всех вхождений из списка
   (DEFUN REMBERALL (n l)
      (COND
         ((NULL l) nil)
         ((EQUAL n (CAR l)) (REMBERALL n (CDR l)))
         (t (CONS (CAR l) (REMBERALL n (CDR l))))
         );COND
      );DEFUN

   ;; Функция определения углового расстояния
   (DEFUN ANGDISTANCE (ang1 ang2)
      (COND
         ((> (ABS (- ang1 ang2)) pi) (- (* 2 pi) (ABS (- ang1 ang2))))
         (t (ABS (- ang1 ang2)))
         );COND
      );DEFUN

   ;; Функция замыкания эллипса
   (DEFUN CLOSEELLIPSE (ed)
      (SETQ
         ed (SUBST (CONS 41 0.0)(ASSOC 41 ed) ed)
         ed (SUBST (CONS 42 (* 2 pi))(ASSOC 42 ed) ed)
         );SETQ
      (ENTMOD  ed)
      );DEFUN

   ;; Функция замыкания дуги
   (DEFUN CLOSEARC (ed / ed1)
      (SETQ
         ed1 ed
         ed1 (REMBERALL (ASSOC -1 ed1) ed1)
         ed1 (REMBERALL (ASSOC 5 ed1) ed1)
         ed1 (REMBERALL (ASSOC 50 ed1) ed1)
         ed1 (REMBERALL (ASSOC 51 ed1) ed1)
         ed1 (REMBERALL (ASSOC 100 ed1) ed1)
         ed1 (REMBERALL (ASSOC 102 ed1) ed1)
         ed1 (REMBERALL (ASSOC 330 ed1) ed1)
         ed1 (REMBERALL (ASSOC 360 ed1) ed1)
         ed1 (SUBST (CONS 0 "CIRCLE")(ASSOC 0 ed1) ed1)
         );SETQ
      (ENTMAKE  ed1)
      (ENTDEL (CDR (ASSOC -1 ed)))
      );DEFUN

   ;;Функция обединения текста
   (DEFUN JOINTEXT (ed1 ed2 / txt1 txt2)
      (SETQ
         txt1 (CDR (ASSOC 1 ed1))
         txt2 (CDR (ASSOC 1 ed2))
         txt1 (IF (= " " (SUBSTR txt1 (STRLEN txt1)))
            (STRCAT txt1 txt2)
            (STRCAT txt1 " " txt2)
            );IF
         );SETQ
      (SETQ ed1 (SUBST (CONS 1 txt1)(ASSOC 1 ed1) ed1))
      (ENTMOD ed1)
      (ENTDEL (CDR (ASSOC -1 ed2)))
      );DEFUN

   ;;Функция обединения отрезков
   (DEFUN JOINLINES (ed1 ed2 / p1 p2 p3 p4 pnt1 pnt2)
      (SETQ
         p1 (CDR (ASSOC 10 ed1))
         p2 (CDR (ASSOC 11 ed1))
         p3 (CDR (ASSOC 10 ed2))
         p4 (CDR (ASSOC 11 ed2))
         );SETQ
      (IF (> (MAX (DISTANCE p1 p3) (DISTANCE p1 p4))
            (MAX (DISTANCE p2 p3) (DISTANCE p2 p4)))
         (SETQ pnt1 p1)
         (SETQ pnt1 p2)
         );IF
      (IF (> (DISTANCE pnt1 p3) (DISTANCE pnt1 p4))
         (SETQ pnt2 p3)
         (SETQ pnt2 p4)
         );IF
      (SETQ
         ed1 (SUBST (CONS 10 pnt1)(ASSOC 10 ed1) ed1)
         ed1 (SUBST (CONS 11 pnt2)(ASSOC 11 ed1) ed1)
         );SETQ
      (ENTMOD ed1)
      (ENTDEL (CDR (ASSOC -1 ed2)))
      );DEFUN

   ;;Функция обединения эллиптических дуг
   (DEFUN JOINELLIPSES (ed1 ed2 / a1 a2 a3 a4 ang1 ang2)
      (COND
         ((NOT (EQUAL (CDR (ASSOC 10 ed1)) (CDR (ASSOC 10 ed2))))
            (PRINC "\nНе совпадают центры дуг! ")
            (IF ed1 (REDRAW (CDR (ASSOC -1 ed1)) 4))
            )
         ((OR
               (NOT (EQUAL (CDR (ASSOC 11 ed1)) (CDR (ASSOC 11 ed2))))
               (NOT (EQUAL (CDR (ASSOC 40 ed1)) (CDR (ASSOC 40 ed2))))
               );OR
            (PRINC "\nНе совпадают полуоси эллипсов! ")
            (IF ed1 (REDRAW (CDR (ASSOC -1 ed1)) 4))
            )
         (t (SETQ
               a1 (CDR (ASSOC 41 ed1))
               a2 (CDR (ASSOC 42 ed1))
               a3 (CDR (ASSOC 41 ed2))
               a4 (CDR (ASSOC 42 ed2))
               );SETQ
            (IF (< (ANGDISTANCE a1 a4) (ANGDISTANCE a2 a3))
               (SETQ
                  ang1 a3
                  ang2 a2
                  );SETQ
               (SETQ
                  ang1 a1
                  ang2 a4
                  );SETQ
               );IF
            (SETQ
               ed1 (SUBST (CONS 41 ang1)(ASSOC 41 ed1) ed1)
               ed1 (SUBST (CONS 42 ang2)(ASSOC 42 ed1) ed1)
               );SETQ
            (ENTMOD ed1)
            (ENTDEL (CDR (ASSOC -1 ed2)))
            );t
         );COND
      );DEFUN

   ;;Функция обединения круговых дуг
   (DEFUN JOINARCHES (ed1 ed2 / a1 a2 a3 a4 ang1 ang2)
      (COND
         ((NOT (EQUAL (CDR (ASSOC 10 ed1)) (CDR (ASSOC 10 ed2))))
            (PRINC "\nНе совпадают центры дуг! ")
            (IF ed1 (REDRAW (CDR (ASSOC -1 ed1)) 4))
            )
         ((NOT (EQUAL (CDR (ASSOC 40 ed1)) (CDR (ASSOC 40 ed2))))
            (PRINC "\nНе совпадают радиусы дуг! ")
            (IF ed1 (REDRAW (CDR (ASSOC -1 ed1)) 4))
            )
         (t (SETQ
               a1 (CDR (ASSOC 50 ed1))
               a2 (CDR (ASSOC 51 ed1))
               a3 (CDR (ASSOC 50 ed2))
               a4 (CDR (ASSOC 51 ed2))
               );SETQ
            (IF (< (ANGDISTANCE a1 a4) (ANGDISTANCE a2 a3))
               (SETQ
                  ang1 a3
                  ang2 a2
                  );SETQ
               (SETQ
                  ang1 a1
                  ang2 a4
                  );SETQ
               );IF
            (SETQ
               ed1 (SUBST (CONS 50 ang1)(ASSOC 50 ed1) ed1)
               ed1 (SUBST (CONS 51 ang2)(ASSOC 51 ed1) ed1)
               );SETQ
            (ENTMOD ed1)
            (ENTDEL (CDR (ASSOC -1 ed2)))
            );t
         );COND
      );DEFUN
 
;;; Основной текст программы
   (SETVAR "CMDECHO" 0)
   (COMMAND "_.undo" "_begin")
   (SETQ ed1 (ENTGET (CAR (ENTSEL "\nВыберите 1-ю линию, дугу или текст"))))
   (WHILE (NOT (MEMBER (CDR (ASSOC 0 ed1)) '("LINE" "ELLIPSE" "ARC" "TEXT")))
      (PROGN
         (PRINC "\nНеверный тип примитива! ")
         (SETQ ed1 (ENTGET (CAR (ENTSEL "\nВыберите 1-ю линию, дугу или текст"))))
         );PROGN
      );IF
   (REDRAW (CDR (ASSOC -1 ed1)) 3)
   (COND
      ((EQ (CDR (ASSOC 0 ed1)) "ARC")
         (SETQ ed2 (ENTSEL "\nВыберите 2-ю дугу или <ENTER>, чтобы замкнуть"))
         (IF (NULL ed2) (CLOSEARC ed1)
            (PROGN
               (SETQ ed2 (ENTGET (CAR ed2)))
               (WHILE (NOT (EQ (CDR (ASSOC 0 ed2)) "ARC"))
                  (PROGN
                     (PRINC "\nНеверный тип примитива! ")
                     (SETQ ed2 (ENTGET (CAR (ENTSEL "\nВыберите 2-ю дугу"))))
                     );PROGN
                  );WHILE
               (JOINARCHES ed1 ed2)
               );PROGN
            );IF
         );ARC
      ((EQ (CDR (ASSOC 0 ed1)) "ELLIPSE")
         (SETQ ed2 (ENTSEL "\nВыберите 2-ю дугу или <ENTER>, чтобы замкнуть"))
         (IF (NULL ed2) (CLOSEELLIPSE ed1)
            (PROGN
               (SETQ ed2 (ENTGET (CAR ed2)))
               (WHILE (NOT (EQ (CDR (ASSOC 0 ed2)) "ELLIPSE"))
                  (PROGN
                     (PRINC "\nНеверный тип примитива! ")
                     (SETQ ed2 (ENTGET (CAR (ENTSEL "\nВыберите 2-ю дугу"))))
                     );PROGN
                  );WHILE
               (JOINELLIPSES ed1 ed2)
               );PROGN
            );IF
         );ELLIPSE
      ((EQ (CDR (ASSOC 0 ed1)) "LINE")
         (SETQ ed2 (ENTGET (CAR (ENTSEL "\nВыберите 2-ю линию"))))
         (WHILE (NOT (EQ (CDR (ASSOC 0 ed2)) "LINE"))
            (PROGN
               (PRINC "\nНеверный тип примитива! ")
               (SETQ ed2 (ENTGET (CAR (ENTSEL "\nВыберите 2-ю линию"))))
               );PROGN
            );WHILE
         (JOINLINES ed1 ed2)
         );LINE
      ((EQ (CDR (ASSOC 0 ed1)) "TEXT")
         (SETQ ed2 (ENTGET (CAR (ENTSEL "\nВыберите 2-й текст"))))
         (WHILE (NOT (EQ (CDR (ASSOC 0 ed2)) "TEXT"))
            (PROGN
               (PRINC "\nНеверный тип примитива! ")
               (SETQ ed2 (ENTGET (CAR (ENTSEL "\nВыберите 2-й текст"))))
               );PROGN
            );WHILE
         (JOINTEXT ed1 ed2)
         );TEXT
      );COND
   (COMMAND "_.undo" "_end")
   (SETVAR "CMDECHO" cmdecho-save)
   (SETQ *error* error-save)
   (PRINC)
   );DEFUN

(IF (OR (NULL C:JOIN1)
      (NOT (LISTP C:JOIN1))
      );OR
   (DEFUN C:JOIN1 ()
      (JOIN1)
      );DEFUN
   );IF
(PRINC "\nJOIN1.lsp загружен... ")
(PRINC "\nДобавлена команда JOIN1...")
(PRINC)
В приложенном файле требуемый результат

Вложения
Тип файла: dwg
DWG 2004
Пример.dwg (50.2 Кб, 431 просмотров)

__________________
Работаю за еду.
Working for food.
Für Essen arbeiten.
العمل من أجل الغذاء
Працую за їжу.
Просмотров: 2897
 
Непрочитано 24.09.2008, 17:15
#2
VVA

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


DEM, Может PLJ подойдет?
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 24.09.2008, 18:16
#3
Dym


 
Регистрация: 27.09.2005
Двинскъ
Сообщений: 586
Отправить сообщение для Dym с помощью Skype™


было здесь недавно *^C^Cpeditaccept;1;_Select;\_Pedit;_M;_P;;_J;;;_peditaccept;0
Dym вне форума  
 
Непрочитано 24.09.2008, 18:30
#4
Profan


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


Только пробел в макросе лишний после _pe
Profan вне форума  
 
Непрочитано 24.09.2008, 18:45
#5
Dym


 
Регистрация: 27.09.2005
Двинскъ
Сообщений: 586
Отправить сообщение для Dym с помощью Skype™


помниться при публикации этого макроса тож пробел лишний влезал, я сейчас просто с кнопки скопировал. Profan> вроде как твоё творение?
Dym вне форума  
 
Непрочитано 24.09.2008, 18:50
#6
Profan


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


Да, я сочинял. Только DEM'а вряд ли устроит этот макрос.
Profan вне форума  
 
Автор темы   Непрочитано 24.09.2008, 21:05
#7
DEM

YngIngKllr
 
Регистрация: 29.03.2005
СПб
Сообщений: 12,968


Цитата:
Сообщение от VVA Посмотреть сообщение
DEM, Может PLJ подойдет?
Нормально но надо чтобы было именно как в примере.
Я просто линиями не черчу использую полилинии.
А иногда нужно не объединить полилинии а удалить последние сегменты и добавить новый сегмент.
Обыкновенная команда _JOIN делает это если полилинии на одной прямой и малейшая погрешность ведет к тому что команда не срабатывает.
__________________
Работаю за еду.
Working for food.
Für Essen arbeiten.
العمل من أجل الغذاء
Працую за їжу.
DEM вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > _JOIN1 до работка команды

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

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


Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Изменение полей (fields) RomanM AutoCAD 20 24.08.2016 22:39
запуск программы из AutoCADа kminas Программирование 19 15.06.2012 13:42
Отображение GRID при выполнении команды PAN REALTIME MAX-MAX AutoCAD 10 29.06.2009 18:43
Последовательность выбора примитива и ввода команды Se-do AutoCAD 4 13.07.2007 00:22
Прозрачные команды Vova AutoCAD 17 21.06.2006 05:33