как выполнить сопряжение для нескольких прямых выделив их секрет рамкой

Роман Амосов · 14.05.2012, 14:46

Здраствуйте уважаемые форумчане. Помогите решить одну задачку. Чтобы выполнить сопряжение двух линий необходимо поочередно кликнуть по каждой из них. Если в чертеже сопряжений одного радиуса более 200 то это напрягает. Можно ли сделать этот процес програмным. Чтобы сопряжение выполнялось для всех линий (попавших в секрет рамку при их выделении) имеющих общую кон. точку. Заранее спасибо.

Дима_ · 14.05.2012, 14:49

Пример выкладывай - посмотрим.

Роман Амосов · 14.05.2012, 15:13

Вот пример. Здесь линии синим цветом (дороги) должны иметь сопряжение 5мм

Олег (jr.) · 15.05.2012, 08:30

Цитата:

Сообщение от Роман Амосов

Вот пример. Здесь линии синим цветом (дороги) должны иметь сопряжение 5мм

Проверяй, вроде работает

Код:

[Выделить все]

;*********************************PJOIN.LSP***********************************
;Written By: PETER JAMTGAARD  at Sunrise Drafting Service @1993
;*****************************************************************************
;This Program Joins ARCS,LINES, AND POLYLINES into POLYLINES
;It also sets widths
;*****************************************************************************
;
(defun C:PJ ()
 (setvar "cmdecho" 0)
 (setq sset2 (ssadd))
 (princ "Select ARCS, LINES, AND POLYLINES to be joined")
 (setq sset (ssget))
 (princ "Enter Polyline Width <0.0>")
 (setq WIDTH (getreal))
 (if (= WIDTH nil)(setq WIDTH 0.0))
 (setq A 0 B 0 C 0)
  (while (= B 0)
   (setq ENT (ssname SSET C))
   (if (= ENT nil)(setq B 1)
    (progn
     (setq c (+ c 1))
     (setq ED (entget ENT))
     (setq TYPE1 (cdr (assoc 0 ED)))
     (if (= TYPE1 "LINE")
      (progn
       (command "pedit" ENT "Y" "W" WIDTH "lt" "ON" "")
       (setq ENT (ssname (ssget "L") 0))
       (ssadd ENT sset2)
      )
      (if (= TYPE1 "ARC")
       (progn
        (command "PEDIT" ENT "Y" "W" WIDTH "lt" "on" "")
        (setq ENT (ssname (ssget "L") 0))
        (SSADD ENT sset2)
       )
       (if (= TYPE1 "POLYLINE")
        (progn
         (setq CLOSEd (cdr (assoc 70 ED)))
         (if (= CLOSEd 1)
          (progn
           (princ "\nRemoved One Closed Polyline")
           (command "PEDIT" ENT "W" WIDTH "lt" "on" "") 
          ) 
          (progn
           (command "PEDIT" ENT "W" WIDTH "lt" "on" "")
           (ssadd ENT SSET2)
          )
         )
        )
       )
      )
     )
    )
   )
  )
  (COMMAND "SELECT" SSET2 "")
  (SETQ B 0)
  (while (= B 0)
   (setq SSET2 (SSGET "p"))
   (IF (= SSET2 nil)(setq B 1)
    (PROGN          
     (setq ENT (ssname SSET2 0))
     (if (= ENT nil)
      (setq B 1)
      (command "pedit" ent "j" sset2 "" "")
     )
    )
   )
  )
 (setvar "cmdecho" 1)
 (command "SELECT" SSET "")
)

Роман Амосов · 15.05.2012, 11:52

Спасибо что потратили свое время. Однако у меня программа не работает.
При вводе кода в строке меню у меня следующее:

Команда: PJ
Select ARCS, LINES, AND POLYLINES to be joined
Выберите объекты: Противоположный угол: найдено: 7
Выберите объекты:
Enter Polyline Width <0.0>
Неизвестная команда "PEDIT". Для вызова справки нажмите F1.
<имя объекта: 7EE8C520>
Неизвестная команда "Y". Для вызова справки нажмите F1.
Неизвестная команда "W". Для вызова справки нажмите F1.
0.000000
*Прервано*

У меня Autocad 2011.

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

Олег (jr.) · 15.05.2012, 23:01

Цитата:

Сообщение от Роман Амосов

Неизвестная команда "PEDIT". Для вызова справки нажмите F1.

Если у тебя локальная версия ставь перед командой нижнее почеркивание:
(command "_PEDIT" ...)

~'o'~

Роман Амосов · 16.05.2012, 12:37

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

Команда: _pj
_Select ARCS, LINES, AND POLYLINES to be joined
Выберите объекты: Противоположный угол: найдено: 3
Выберите объекты: найдено: 1, всего: 4
Выберите объекты: Противоположный угол: найдено: 5, всего: 9
Выберите объекты:
Enter Polyline Width <0.0>
Ответьте Да или Нет.
; ошибка: Функция прервана.
Сделать его полилинией? <Д>
Задайте параметр [Замкнуть/Добавить/Ширина/Вершина/СГладить/СПлайн/Убрать
сглаживание/Типлин/оБратить/Отменить]: *Прервано*

При запросе соманды pedit что выбирать?
Задайте параметр [Замкнуть/Добавить/Ширина/Вершина/СГладить/СПлайн/Убрать
сглаживание/Типлин/оБратить/Отменить][/i]

Где в коде строчка определяющая радиус сопряжения?

Если не сложно опишите как программа должна работать. Я в этом совсем ничего не понимаю.

getr · 16.05.2012, 12:44

а этой строчки в коде нетути...это не тот лисп который вам нужен..он не рисует сопряжения,а объединяет в полилинии..

Роман Амосов · 16.05.2012, 12:51

Этот вариант мне не подходит. Дикое желание выделять объекты рамкой и при запросе радиуса сопряжения все элементы имеющие общую точку на конце приметива образуют сопряжение.

Неужели не у кого небыло такого желания. Или с этим никто не сталкивался? Господа програмисты, не дайте мне пустить корни за компом.

ciril · 22.05.2012, 11:53

Уж не знаю, актуально еще или нет, но выкладываю

Код:

[Выделить все]

 (defun c:soupl  (/ x00 x01 x02 x03 x04 x05 x06 x07 x08 x09 x0a x0b x0c)
  (initget 6)
  (setq x00 (getreal "\nВведите радиус закругления: "))
  (setq x01 '((nil (0.0 . (/ pi 2)) nil ((/ (* pi 3) 2) . 0.0))
              ((0.0 . (/ pi 2)) nil ((/ pi 2) . pi) nil)
              (nil ((/ pi 2) . pi) nil (pi . (/ (* pi 3) 2)))
              (((/ (* pi 3) 2) . 0.0) nil (pi . (/ (* pi 3) 2)) nil)))
  (while (setq x02 (ssget '((0 . "line"))))
    (setq x03 (list)
          x04 -1)
    (repeat (sslength x02)
      (setq x03 (append x03
                        (list (cdr (assoc 10 (setq x06 (entget (setq x05 (ssname x02 (setq x04 (1+ x04))))))))
                              (cdr (assoc 11 x06)))))
      (entdel x05))
    (setq x02 nil
          x04 (list))
    (while x03
      (setq x05 (car x03)
            x06 (cadr x03))
      (or (and (or (and (setq x07 (car (setq x02 (member x05 (cdr x03)))))
                        (setq x05 (polar x06 (setq x08 (angle x06 x05)) (- (distance x06 x05) x00))
                              x0c (nth (rem (setq x08 (fix (* x08 (/ 2 pi)))) 2) x05)))
                   (and (setq x07 (car (setq x02 (member x06 (cddr x03)))))
                        (setq x06 (polar x05 (setq x08 (angle x05 x06)) (- (distance x05 x06) x00))
                              x0c (nth (rem (setq x08 (fix (* x08 (/ 2 pi)))) 2) x06))))
               (progn (setq x09 (car x02)
                            x0a (cadr x02)
                            x02 (cddr x02))
                      (if x0a
                        (or (zerop (rem (setq x0b (- (length x03) (length x02) 2)) 2))
                            (setq x02 (cons x0a x02)
                                  x0a x09
                                  x09 (nth (setq x0b (1- x0b)) x03)))
                        (setq x0b (length x03)
                              x0a x09
                              x09 (cadr (reverse x03))))
                      (if (equal x07 x09)
                        (setq x09 (polar x0a (setq x07 (angle x0a x09)) (- (distance x0a x09) x00))
                              x0c (if (zerop (rem (setq x07 (fix (* x07 (/ 2 pi)))) 2))
                                    (list 10 (car x09) x0c 0.0)
                                    (list 10 x0c (cadr x09) 0.0)))
                        (setq x0a (polar x09 (setq x07 (angle x09 x0a)) (- (distance x09 x0a) x00))
                              x0c (if (zerop (rem (setq x07 (fix (* x07 (/ 2 pi)))) 2))
                                    (list 10 (car x0a) x0c 0.0)
                                    (list 10 x0c (cadr x0a) 0.0))))
                      (setq x0a (list x09 x0a))
                      (entmake (list '(0 . "ARC")
                                     x0c
                                     (cons 40 x00)
                                     (cons 50 (eval (car (setq x09 (nth x07 (nth x08 x01))))))
                                     (cons 51 (eval (cdr x09)))))
                      (setq x09 (list))
                      (repeat x0b
                        (setq x09 (append x09 (list (car x03)))
                              x03 (cdr x03)))
                      (setq x03 (append x09 x02 (list x05 x06) x0a))))
          (setq x04 (append x04 (list x05 x06))))
      (setq x03 (cddr x03)))
    (repeat (/ (length x04) 2)
      (entmake (list '(0 . "LINE") (cons 10 (car x04)) (cons 11 (cadr x04))))
      (setq x04 (cddr x04))))
  (princ))

Будет работать для ортогональных отрезков. Выбирает все отрезки, попадающие в рамку выбора.

Роман Амосов · 22.05.2012, 12:07

Спасибо что откликнулись. Тема до сих пор актуальна т.к. задача так и не решена.

Я наверно чего то не понимаю, но при вводе кода в строку получаю следующее

Команда: (defun c:soupl (/ x00 x01 x02 x03 x04 x05 x06 x07 x08 x09 x0a x0b x0c)
(_> 02 (initget 6)
(_> 03 (setq x00 (getreal "\nВведите радиус закругления: "))
(_> 04 (setq x01 '((nil (0.0 . (/ pi 2)) nil ((/ (* pi 3) 2) . 0.0))
(('(_> 05 ((0.0 . (/ pi 2)) nil ((/ pi 2) . pi) nil)
(('(_> 06 (nil ((/ pi 2) . pi) nil (pi . (/ (* pi 3) 2)))
(('(_> 07 (((/ (* pi 3) 2) . 0.0) nil (pi . (/ (* pi 3) 2)) nil)))
(_> 08 (while (setq x02 (ssget '((0 . "line"))))
((_> 09 (setq x03 (list)
(((_> 10 x04 -1)
((_> 11 (repeat (sslength x02)
(((_> 12 (setq x03 (append x03
(((((_> 13 (list (cdr (assoc 10 (setq x06 (entget (setq
x05 (ssname x02 (setq x04 (1+ x04))))))))
((((((_> 14 (cdr (assoc 11 x06)))))
(((_> 15 (entdel x05))
((_> 16 (setq x02 nil
(((_> 17 x04 (list))
((_> 18 (while x03
(((_> 19 (setq x05 (car x03)
((((_> 20 x06 (cadr x03))
(((_> 21 (or (and (or (and (setq x07 (car (setq x02 (member x05 (cdr
x03)))))
(((((((_> 22 (setq x05 (polar x06 (setq x08 (angle x06
x05)) (- (distance x06 x05) x00))
((((((((_> 23 x0c (nth (rem (setq x08 (fix (* x08
(/ 2 pi)))) 2) x05)))
((((((_> 24 (and (setq x07 (car (setq x02 (member x06 (cddr
x03)))))
(((((((_> 25 (setq x06 (polar x05 (setq x08 (angle x05
x06)) (- (distance x05 x06) x00))
((((((((_> 26 x0c (nth (rem (setq x08 (fix (* x08
(/ 2 pi)))) 2) x06))))
(((((_> 27 (progn (setq x09 (car x02)
(((((((_> 28 x0a (cadr x02)
(((((((_> 29 x02 (cddr x02))
((((((_> 30 (if x0a
(((((((_> 31 (or (zerop (rem (setq x0b (- (length x03)
(length x02) 2)) 2))
((((((((_> 32 (setq x02 (cons x0a x02)
(((((((((_> 33 x0a x09
(((((((((_> 34 x09 (nth (setq x0b (1- x0b))
x03)))
(((((((_> 35 (setq x0b (length x03)
((((((((_> 36 x0a x09
((((((((_> 37 x09 (cadr (reverse x03))))
((((((_> 38 (if (equal x07 x09)
(((((((_> 39 (setq x09 (polar x0a (setq x07 (angle x0a
x09)) (- (distance x0a x09) x00))
((((((((_> 40 x0c (if (zerop (rem (setq x07 (fix
(* x07 (/ 2 pi)))) 2))
(((((((((_> 41 (list 10 (car x09) x0c 0.0)
(((((((((_> 42 (list 10 x0c (cadr x09) 0.0)))
(((((((_> 43 (setq x0a (polar x09 (setq x07 (angle x09
x0a)) (- (distance x09 x0a) x00))
((((((((_> 44 x0c (if (zerop (rem (setq x07 (fix
(* x07 (/ 2 pi)))) 2))
(((((((((_> 45 (list 10 (car x0a) x0c 0.0)
(((((((((_> 46 (list 10 x0c (cadr x0a)
0.0))))
((((((_> 47 (setq x0a (list x09 x0a))
((((((_> 48 (entmake (list '(0 . "ARC")
((((((((_> 49 x0c
((((((((_> 50 (cons 40 x00)
((((((((_> 51 (cons 50 (eval (car (setq x09
(nth x07 (nth x08 x01))))))
((((((((_> 52 (cons 51 (eval (cdr x09)))))
((((((_> 53 (setq x09 (list))
((((((_> 54 (repeat x0b
(((((((_> 55 (setq x09 (append x09 (list (car x03)))
((((((((_> 56 x03 (cdr x03)))
((((((_> 57 (setq x03 (append x09 x02 (list x05 x06)
x0a))))
((((_> 58 (setq x04 (append x04 (list x05 x06))))
(((_> 59 (setq x03 (cddr x03)))
((_> 60 (repeat (/ (length x04) 2)
(((_> 61 (entmake (list '(0 . "LINE") (cons 10 (car x04)) (cons 11 (cadr
x04))))
(((_> 62 (setq x04 (cddr x04))))
(_> 63 (princ))
; ошибка: синтаксическая ошибка
Команда: *Прервано*
Команда: soup
Неизвестная команда "SOUP". Для вызова справки нажмите F1.
Команда: _soup
Неизвестная команда "SOUP". Для вызова справки нажмите F1.

Подскажите может я чего не так делаю?

Astartes · 22.05.2012, 12:17

ciril, Все работает.

Роман Амосов, Это лисп. http://dwg.ru/art/8

ciril · 22.05.2012, 12:17

Вы скопировали код с номерами строк - они лишние. В правом верхнем углу окна кода появляющаяся строка с иконками, левая открывает окно чистого кода, из него копируйте

Роман Амосов · 22.05.2012, 12:23

О Yesssssss УРААААААААА Все заработало. Огромное спасибо. Этой функции а САDe точно не хватало. Обалденая экономия времени.

Astartes · 22.05.2012, 12:26

ciril, Если линии перпендикулярны, то нормально работает. Если линии под другим углом, тогда остается дуга, а линии удаляются.
Не знаю как автору вопроса, можно было бы еще добавить чтобы, предыдущее значение радиуса сохраналось.

Блин. Чето совсем непонятно. Раз на раз не приходится. Походу зависит от такого каким образом были начерчены линии. Иногда удаляет вообще все и линии и дугу. Иногда отрисовывает все нормально даже с линиями под углами отличными от 90.

ciril · 22.05.2012, 12:26

Да не за что

Еще раз подчеркну, что на отрезках, которые неортогональны в МСК, будет прерываться с ошибкой, также будет прерываться с ошибкой на невзаимоперпендикулярных отрезках. При совпадении более двух узлов - результат непредсказуем

Я чуть позже поправлю ее, чтобы работала на невзаимоперпендикулярных.
Astartes, там непредсказуемый результат: углы из списка x01, а позиция в списке - округление угла, под которым расположен отрезок. Такое решение - самое простое, другое пока не придумалось

Роман Амосов · 22.05.2012, 12:31

ciril · 24.05.2012, 16:32

Вот так

Код:

[Выделить все]

 (defun c:soupl  (/ x00 x01 x02 x03 x04 x05 x06 x07 x08 x09 x0a xff)
  (initget 4)
  (or (setq xff (getreal "\nВведите значение допуска: <0.00000001> ")) (setq xff 1.0e-008))
  (initget 7)
  (setq x00 (getreal "\nВведите радиус сопряжения: "))
  (while (setq x01 (ssget '((0 . "line"))))
    (setq x02 (list)
          x03 -1)
    (repeat (sslength x01)
      (setq x02 (append x02
                        (list (cdr (assoc 10 (setq x05 (entget (setq x04 (ssname x01 (setq x03 (1+ x03))))))))
                              (cdr (assoc 11 x05)))))
      (entdel x04))
    (setq x01 nil)
    (while x02
      (setq x03 (car x02)
            x04 (cadr x02))
      (or (equal x03 x04 xff)
          (and (or (setq x05 (cddr x02)
                         x01 (if (or (while (and x05 (not (equal x03 (car x05) xff))) (setq x05 (cdr x05))) x05)
                               x05))
                   (and (setq x05 (cddr x02)
                              x01 (if (or (while (and x05 (not (equal x04 (car x05) xff))) (setq x05 (cdr x05))) x05)
                                    x05))
                        (setq x05 x03
                              x03 x04
                              x04 x05)))
               (progn (setq x05 (angle x04 x03)
                            x06 (car x01)
                            x07 (cadr x01)
                            x01 (cddr x01)
                            x08 (- (length x02) 2))
                      (if x07
                        (or (zerop (rem (setq x08 (- x08 (length x01))) 2))
                            (setq x01 (cons x07 x01)
                                  x07 (nth (setq x08 (1- x08)) x02)))
                        (setq x07 (cadr (reverse x02))))
                      (setq x09 (list))
                      (repeat x08
                        (setq x09 (append x09 (list (car x02)))
                              x02 (cdr x02)))
                      (and (equal x03 x07 xff)
                           (setq x02 x06
                                 x06 x07
                                 x07 x02))
                      (setq x08 (angle x07 x06))
                      (and (> x05 x08)
                           (setq x02 x03 x03 x06 x06 x02 x02 x04 x04 x07 x07 x02 x02 x05 x05 x08 x08 x02))
                      (setq x02 (append x09
                                        x01
                                        (if (or (zerop (setq x02 (+ x05 (- (* 2 pi) x08))
                                                             x0a (- x08 x05)))
                                                (eq pi (abs x0a)))
                                          (progn (entmake (list '(0 . "LINE") (cons 10 x03) (cons 11 x04)))
                                                 (entmake (list '(0 . "LINE") (cons 10 x06) (cons 11 x07)))
                                                 (list))
                                          (progn (and (> x0a x02)
                                                      (setq x0a x02 x02 x03 x03 x06 x06 x02 x02 x04 x04 x07 x07 x02 x02 x05 x05 x08 x08 x02))
                                                 (setq x03 (polar x04 x05 (- (distance x04 x03) (setq x02 (* x00 (/ (cos (setq x0a (/ x0a 2))) (sin x0a))))))
                                                       x06 (polar x07 x08 (- (distance x07 x06) x02)))
                                                 (entmake (list '(0 . "ARC")
                                                                (cons 10 (polar x03 (- x05 (/ pi 2)) x00))
                                                                (cons 40 x00)
                                                                (cons 50 (- x08 (/ pi 2)))
                                                                (cons 51 (+ x05 (/ pi 2)))))
                                                 (list x03 x04 x06 x07)))))))
          (entmake (list '(0 . "LINE") (cons 10 x03) (cons 11 x04))))
      (setq x02 (cddr x02))))
  (princ))

Дополнительно запрашивает допуск совпадения узлов отрезков. Не строит дугу, если угол между отрезками 0 или 180, не строит отрезки 0й длины.

Astartes · 25.05.2012, 05:18

Спасибо.
Вроде пока все работает, только если установлен вид "Сверху". В други стандартных ортогональных видах, не работает.

ciril · 25.05.2012, 13:13

Не, немного не так

Работает при любых видах для отрезков, построенных в плоскости XY в МСК. Чтобы работало для других плоскостей построения доделаю

14.05.2012, 14:46		#1
как выполнить сопряжение для нескольких прямых выделив их секрет рамкой Роман Амосов энергетик Владивосток Регистрация: 01.03.2012 Сообщений: 72 Здраствуйте уважаемые форумчане. Помогите решить одну задачку. Чтобы выполнить сопряжение двух линий необходимо поочередно кликнуть по каждой из них. Если в чертеже сопряжений одного радиуса более 200 то это напрягает. Можно ли сделать этот процес програмным. Чтобы сопряжение выполнялось для всех линий (попавших в секрет рамку при их выделении) имеющих общую кон. точку. Заранее спасибо.
Просмотров: 4541