Нужен лисп, который высчитывает уклон линии

ВоваН · 14.11.2005, 09:30

Нужен лисп, который высчитывает уклон линии.

Берем у выделенной линии Delta X, Delta Y и производим следующую операцию:

(Delta Y / Delta X)*1000

Результат выводим в командную строку.

Спасибо

Кулик Алексей aka kpblc · 14.11.2005, 10:04

Код:

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

(defun c:delta_line (/ ent result d_x d_y)
  (setq ent (ssget "_:S"))
  (if ent
    (progn
      (setq ent (entget (ssname ent 0)))
      (if (= (cdr (assoc 0 ent)) "LINE")
	(progn
	  (setq	d_x    (abs
			 (- (car (cdr (assoc 10 ent)))
			    (car (cdr (assoc 11 ent)))
			    ) ;_ end of -
			 ) ;_ end of abs
		d_y    (abs (- (cadr (cdr (assoc 10 ent)))
			       (cadr (cdr (assoc 11 ent)))
			       ) ;_ end of -
			    ) ;_ end of abs
		result (* (/ d_x d_y) 1000)
		) ;_ end of setq
	  (princ (strcat "\n" (rtos result 2 4)))
	  ) ;_ end of progn
	(princ "\nОбрабатываются только отрезки!")
	) ;_ end of if
      ) ;_ end of progn
    ) ;_ end of if
  (princ)
  ) ;_ end of defun

Эдуард · 14.11.2005, 11:41

Или так

Код:

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

(defun C:uklon (/ lin)
  (if
    (and
      (setq lin (car (entsel)))
      (equal (cdr (assoc 0 (entget lin))) "LINE")
    )
     (*	1000
	(abs
	  (apply
	    '/
	    (cdr
	      (reverse
		(vlax-safearray->list
		  (vlax-variant-value
		    (vla-get-Delta (vlax-ename->vla-object lin))
		  )
		)
	      )
	    )
	  )
	)
     )
  )
)

ВоваН · 14.11.2005, 15:19

Все получилось, только вместо:
result (* (/ d_x d_y) 1000)

нужно поставить:
result (* (/ d_y d_x) 1000)

Лентяй · 14.11.2005, 21:41

Не люблю смешения французского с нижегородским. А посему - ловите чистый ActveX:

Код:

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

(defun C:Slope (/ dlt)
  (vla-getentity (vla-get-utility(vla-get-ActiveDocument (vlax-get-acad-object)))
    'ln (vlax-make-variant "\nSelect line: "))
  (setq dlt (vlax-get ln 'delta))
  (print (strcat "\nSlope: " (rtos (* (/ (cadr dlt) (car dlt)) 1000))))
);end

Пользуйтесь и не забывайте благодарить меня, любимого, за то, что я есть.

Apelsinov · 15.11.2005, 09:53

Лентяй
Мне оч. понравилось уже. Но как отлавливать пустой выбор?
и почему-то строка запроса по умолчанию.

Код:

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

(defun C:Slope (/ dlt ln) 
  (vla-getentity (vla-get-utility(vla-get-ActiveDocument (vlax-get-acad-object))) 
    'ln (vlax-make-variant "\nSelect line: ")) 
  (setq dlt (vlax-get ln 'delta))
  (princ (strcat "\nSlope: " (rtos (* (/ (cadr dlt) (car dlt)) 1000))))
  (princ)
)

Лентяй · 15.11.2005, 10:58

Цитата:

Apelsinov: Но как отлавливать пустой выбор?

Сачком! В крайнем случае - неводом. Лентяй здесь - Я.

Цитата:

и почему-то строка запроса по умолчанию.

Эт вы об чем?

Apelsinov · 15.11.2005, 11:28

Цитата:

Сачком! В крайнем случае - неводом. Лентяй здесь - Я.

Да ктож спорит! Но ты (именно с маленькой, дабы не смущать умы) наверняка знаешь как сделать этот сачок. А я не знаю. Я вообще такой способ выбора впервые вижу. Посему, ежели будет время - ответь ПОЖАЛУЙСТА.

Цитата:

Эт вы об чем?

О том, что у меня. например, идет запрос на выбор - "Select object:" а не "Select line:".

Лентяй · 15.11.2005, 11:56

Цитата:

Apelsinov: Но ты (именно с маленькой, дабы не смущать умы) наверняка знаешь как сделать этот сачок. А я не знаю. Я вообще такой способ выбора впервые вижу. Посему, ежели будет время - ответь ПОЖАЛУЙСТА.

Apelsinov, вот, как честный человек - не знаю. Знаю только, что vl-catch не катит.

Цитата:

О том, что у меня. например, идет запрос на выбор - "Select object:" а не "Select line:".

С этим просто. Добавить после 'ln неиспользуемый параметр 'pt

Код:

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

(vla-getentity (vla-get-utility(vla-get-ActiveDocument (vlax-get-acad-object))) 
    'ln 'pt (vlax-make-variant "\nSelect line: "))

Вообще-то это будет точка выбора, типа как в enеsel. Но тогда почему-то пояляется "правильный запрос". А вот если либо pt, либо (vlax-make-variant "\nSelect line: ") опустить, тогда будет запрос по умолчанию. Мистика-с.

Apelsinov · 15.11.2005, 12:17

а еще можно:

Код:

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

(vla-getentity (vla-get-utility(vla-get-ActiveDocument (vlax-get-acad-object))) 'ln  pt  "Select line:")

Странно это...

Apelsinov · 15.11.2005, 14:41

Вот.

Код:

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

(defun C:Slope (/ dlt ln pt err_obj err_mes)
  (if (not
	(vl-catch-all-error-p
	  (setq	err_obj	(VL-CATCH-ALL-APPLY
			  (function
			    (lambda ()
			      (vla-getentity
				(vla-get-utility
				  (vla-get-ActiveDocument
				    (vlax-get-acad-object)
				  )
				)
				'ln
				'pt
				"Select line:"
			      )
			    )
			  )
			)
	  )
	)
      )
    (progn
      (if (vlax-property-available-p ln 'delta nil)
	(progn
	  (setq dlt (vlax-get ln 'delta))
	  (princ (strcat "\nSlope: "
			 (rtos (* (/ (cadr dlt) (car dlt)) 1000))
		 )
	  )
	)
	(setq err_mes "У этой хрени дельты нет!")
      )
    )
    (setq err_mes (VL-CATCH-ALL-ERROR-MESSAGE err_obj))
  )
  (if err_mes
    (princ err_mes)
  )
  (princ)
)

Tserber · 15.11.2005, 18:28

Я пользуюсь СПДС, и проблем таких не имею вообще [sm2103]

{Smirnoff} · 15.11.2005, 21:32

В заданной точке, на линиях, полилиниях, окружностях, эллисах, сплайнах, дугах, и х-линиях.

Код:

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

(defun c:klon(/ pt sset crv par der)
 (vl-load-com)
  (princ "\nУкажите точку на линии ")
  (and
    (setq pt(getpoint))
    (setq sset(ssget pt))
    (setq crv(ssname sset 0))
    (setq par(vlax-curve-getParamAtPoint crv pt))
    (setq der(vlax-curve-getFirstDeriv crv par))
    (princ(strcat "\nУклон = "
		  (rtos(* 1000(/(cadr der)(car der))))))
    ); end and
  (princ)
  ); end of c:klon

Нужно включить привязки.

Лентяй · 15.11.2005, 21:59

Что же вы, {Smirnoff}, забыли конвертировать примитив в обьект?

Ай-ай-ай, а еще модератор...

Код:

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

(setq crv (vlax-ename->vla-object (ssname sset 0)))

Или так:

Код:

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

(setq crv (vla-item sset 0))

{Smirnoff} · 15.11.2005, 22:10

>Лентяй
Вот что я забыл то это (vl-load-com). Изучайте матчасть...

fixo · 15.11.2005, 22:23

Хочу напомнить, что уклон: в геодезии, показатель крутизны склона; отношение превышения местности к горизонтальному протяжению, на котором оно наблюдается (напр., уклон, равный 0,015, соответствует подъему 15 м на 1000 м расстояния).
Это что у нас, как считают уклоны за бугром не знаю

Лентяй · 16.11.2005, 11:33

>Apelsinov Что-то у вас сачок сильно больше бабочки получился. Хотя пустая lambda - это круто.

Apelsinov · 16.11.2005, 11:48

Лентяй
Ну было же

Цитата:

В крайнем случае - неводом

вот и получился невод...
зато ловит :wink:

А что большой, так это скорее закономерность. Пустой стакан.

Зы.
Обращение ко мне на "вы" (с маленькой) вызывает у меня раздвоение личности. на "Вы" - ощущение неравноправия, я ж тыкаю.

eax · 17.11.2005, 19:31

давай электронку, вышлю прогу

... на Delphi

sinitsin1983 · 11.03.2012, 23:26

знатоки лиспа, и акада
а если нужен не просто уклон линии в точке,
а средний уклон 3д полилинии (например зигзагообразной канавы на склоне горы) усредненный по длинне ????

Дима_ · 11.03.2012, 23:45

если что-то нужно - то надо описать МАТЕМАТИЧЕСКИ что такое средний уклон и усредненная длинна, если с математикой плохо - нарисовать пару примеров - чтоб было понятно что на что делить и что с чем складывать - там глядишь и програмку нарисуют.
Offtop: не создать ли нам FAQ высвечиваемый при создании новой темы в этом разделе - как правильно задать вопрос (запрос) на написание чего-либо.

Владимир. · 12.03.2012, 10:40

Цитата:

Сообщение от sinitsin1983

усредненный по длинне ????

Это зачем может быть нужно?
Просто взять точку начала и конца канавы и посчитать этот один уклон от начала до конца канавы

sinitsin1983 · 13.03.2012, 22:38

математика с примером

Дима_ · 14.03.2012, 10:29

Расстрою я тебя немножко - у тебя в рисунке обычные (а не "обещенные" 3D) полилинии, то есть лежат в одной плоскости, соответственно "взять высоту" (Z) можно лишь "поискав" рядом с вершиной тескт содержащий цифру и предположив, что это высота. Решение может быть только изначально кривое (т.к. вместо высоты может попасться все что угодно) - а поработав с кривым - ты через неделю попросишь "выловить блох" - и так до бесконечности - короче я его делать точно не буду.

sinitsin1983 · 15.03.2012, 21:45

вот 3d

Дима_ · 16.03.2012, 11:40

Вот код:

Код:

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

 (vl-load-com)
(defun c:uklon()
  ((lambda (togradus ents)
     (if (and ents
              (= (cdr(assoc 0 (entget (car ents))))
                 "POLYLINE"))
         ((lambda (pt1 pt2 len)
            ((lambda (deltaz pram)
               (princ (strcat "\nДлинна: по прямой - " (rtos pram)
                              ", зигзагом - " (rtos len)
                              "; перепад высоты - " (rtos deltaz) 
                              "\nУклон: по прямой - " (rtos (togradus (/ deltaz pram)))
                              ", зигзагом - "(rtos (togradus (/ deltaz len)))".")))
             (abs (- (caddr pt1) (caddr pt2)))
             (distance pt1 pt2)))
          (vlax-curve-getstartpoint (car ents))
          (vlax-curve-getendpoint (car ents))
          (vla-get-length (vlax-ename->vla-object (car ents))))
         (princ "Что то не то выбрали."))
     (princ))
   (lambda (x) (* 180 (/ (atan x) pi)))         
   (entsel "\n Выберите 3Д полилинию: ")))

Composter · 23.03.2012, 19:31

http://forum.abok.ru/index.php?showtopic=66478 вот мой вариант лиспа для проставления отметок с учетом уклона

zikyha · 30.08.2015, 21:12

Товарищи думаю у многих есть такой лисп, по форуму поискал но все что то нето. Нужно что бы лисп выносил на выноске или в Командной строке уклон для прямой между двуся точками, с координатой х,y.
Програмка нужна чтоб проверять профили и самому проставлять уклоны труб. В моем понимании это будет просто Дельта Y/ Дельта X = цифра эту цифру или на выноске или в командную строку. Нужно еще возможноть задать масштаб по горизонтале и вертикали.

Oleg T · 30.08.2015, 21:25

http://forum.zwsoft.ru/viewtopic.php?t=259
Пункт 5
Под акадом тоже должно работать

zikyha · 30.08.2015, 21:46

не работает пишет неизвестная программа.

Vladimir_Sergeevich · 31.08.2015, 09:35

zikyha, есть, но не всегда такой
я для себя писал просто с выводом в ком строку, без выносок. Ничего лишнего, одна арифметика.

Код:

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

 (defun c:uk ( / x1 x2)
(setq x1 (getpoint "\nпервая точка"))
(setq x2 (getpoint "\nвторая точка"))
(princ "\nуклон отрезка: ")
(princ (* (/ (- (cadr x1) (cadr x2)) (- (car x1) (car x2))) 1000)) 
(princ) 
);end

Если надо что бы это выводилось текстом - добавляй нужные запросы на положение текста, и в 5ой строке вместо princ сохранить строку в переменную для дальнейшего использования
з.ы. если масштабы по осям разные - надо, опять же, добавлять нужный запрос и в зависимости от полученного значения просчитывать разные варианты.

Prodiver · 20.10.2016, 10:38

Здравствуйте уважаемые форумчане. Работаю проектировщиком по газоснабжению соответственно приходится делать много километров профилей. Хочу попросить Вас о помощи. Нужен лисп для расчета уклона газопровода в промилле.Суть задачи в следующем: есть две отметки (мтекст)-одна большая, другая меньшая и длина участка (мтекст). Отметки-с двумя знаками после запятой, длина участка-с одним знаком. Указываем на экране большую отметку, меньшую отметку и длину участка. Программа считает уклон по формуле

большая отметка-меньшая отметка)х1000/длину участка, и заменяет любой указанный мтекст на значение рассчитанного уклона с двумя знаками после запятой. Разделитель именно запятая. Конечно, все это считается на простом калькуляторе или в Exсel, что я собственно и делаю. Но с липсом было бы гараздо оперативнее. В нете к сожалению ничего похожего найти не удалось.Буду признателен всем кто отзовется. Работаю на Autocad 2016х32.
Такой лисп в связке с лиспом уважаемого Composter был бы просто находкой. Хочу сказать большое спасибо Composter за его программу по простановке отметок на профиле, пользуюсь постоянно. Правда методом "научного тыка" немного подточил ее "напильником" (к сожалению лисп не знаю) под свою работу. Теперь отметка ставиться с двумя знаками, разделитель запятая и горизонтальный масштаб 1:500. Искренне надеюсь что автор автор не обидится.

Vladimir_Sergeevich · 20.10.2016, 14:10

Prodiver, например так

Код:

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

 (defun c:iv2 ( / ) 
(princ 
	(strcat "\nУклон: " 
		(rtos (* (/ (- (atof (vl-string-subst "." "," (vla-get-textstring (vlax-ename->vla-object (car (entsel "\nпервая отметка:")))))) 
                                          (atof (vl-string-subst "." "," (vla-get-textstring (vlax-ename->vla-object (car (entsel "\nвторая отметка:"))))))
                                 ) 
                                 ;;(getdist "\nмежду точками: ") 
				(atof (vl-string-subst "." "," (vla-get-textstring (vlax-ename->vla-object (car (entsel "\nрасстояние:")))))) 
				) 
             1000) 
		2 2)
);strcat
);princ
(princ)
);end

результат будет в командной строке выводится. работаю в акад 2010, думаю в 2016 тоже должно нормально отработать.
Облагораживать самостоятельно...

skkkk · 21.10.2016, 01:47

Prodiver, нужный код есть тут в #509 (спасибо CB): Как сосчитать сумму цифр из отдельных мтекстов.
Только тот код вроде до одного знака после запятой, но там же, чуть выше написано, где что поменять, чтоб стало два. К тому же тот лисп берет разность по модулю, то есть, не важно, большую или меньшую отметку кликать первой.
P.S.: Сейчас придет trir и скажет: "Civil 3D!"

Do$ · 22.10.2016, 13:07

Цитата:

Сообщение от skkkk

P.S.: Сейчас придет trir и скажет: "Civil 3D!"

И будет прав

Prodiver · 23.10.2016, 16:19

Добрый вечер всем. Хочу поделится новостью, но все по порядку. Vladimir_Sergeevich, спасибо что откликнулись на просьбу. Попробовал Ваш код на Autocad 2016, к сожалению он не пошел. Команды набираются, а результат в ком. строку не выводится. А вот так случилось, что skkkk меня очень удачно "послал" по ссылке. Там действительно есть практически то, что нужно, только пришлось немного изменить кое что и в итоге все работает именно так как и нужно.Большое спасибо Всем кто помог с темой и авторам программ. Решил выложить то, чем сейчас пользуюсь, может кому пригодиться:

Код:

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

 (defun c:z-calc-text-value_1 (/ value ent obj)
  (vl-load-com)
  (princ
    "\nВыберите текстовые объекты среди которых будет произведененна калькуляция"
  ) ;_ end of princ
  (setq value
  (rtos
    (apply
      '(lambda (a b c) (/ (abs (* (- a b) 1000)) c.))
      (mapcar
        (function
   (lambda (a)
     (atof
       (vl-string-trim
         "%Uu {\\Ll}"
         (vl-string-subst
    "."
    ","
    (mip_MTEXT_Unformat
      (cdr (assoc 1 (entget a)))
    ) ;_Снос форматирования
         ) ;_ vl-string-subst
       ) ;_ vl-string-trim
     ) ;_ atof
   ) ;_ lambda
        ) ;_ function
        (mapcar
   '(lambda (x / obj)
      (princ (strcat "\n" x))
      (while
        (not
   (and (setq obj
        (car (entsel (princ (strcat "\r" x))))
        ) ;_ end of setq
        (vl-string-search "TEXT" (cdr (assoc 0 (entget obj))))
   ) ;_ end of and
        ) ;_ end of not
      ) ;_ end of while
      obj
    ) ;_ end of lambda
   (list
     "Текст А :"
     "Текст B :"
     "Текст C :"
   ) ;_ end of list
        ) ;_ end of mapcar
      ) ;_ mapcar
    ) ;_ apply
  ) ;_ end of rtos
  ) ;_ end of setq
  (if (vl-string-position (ascii ".") value)
    (setq value (vl-string-right-trim ".0" value))
  ) ;_ if
  
Код
(setq value (vl-string-subst "," "." value))
(princ (strcat "\nРезультат = " value))
  (alert (strcat "Результат = " value))
  (setvar "ERRNO" 0)
  (while
    (and (not (setq ent
       (car
         (nentsel
    (strcat
      "\n Выберите текстовый объект для записи значения <Выход>:"
    ) ;_ strcat
         ) ;_ entsel
       ) ;_ car
       ) ;_ setq
  ) ;_ not
  (equal (getvar "ERRNO") 7)
    ) ;_ and
     (setvar "ERRNO" 0)
  ) ;_ while
  (if (and ent
    (vlax-property-available-p
      (setq obj (vlax-ename->vla-object ent))
      'TextString
    ) ;_ vlax-property-available-p
    (vlax-write-enabled-p obj)
      ) ;_ and
    (progn
      (vlax-put-property obj 'TextString value)
      (vla-put-color obj 7) ;_Цвет текста 7
      (vlax-release-object obj)
    ) ;_ progn
  ) ;_ if
  (princ)
  ) ;_ defun
(defun mip_MTEXT_Unformat ( Mtext / text Str )
  (setq Text "")
   (while (/= Mtext "")
        (cond
          ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
            (setq Mtext (substr Mtext 3) Text   (strcat Text Str)))
          ((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
          ((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
    (setq Mtext (substr Mtext 3)))
          ((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
            (setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
          ((wcmatch (strcase (substr Mtext 1 2)) "\\P")
            (if (or(= " " (substr Text (strlen Text)))
     (= " " (substr Mtext 3 1)))
               (setq Mtext (substr Mtext 3))
               (setq Mtext (substr Mtext 3) Text (strcat Text " "))))
   ((wcmatch (strcase (substr Mtext 1 2)) "\\S")
            (setq Str   (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
                  Text  (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
                  Mtext (substr Mtext (+ 4 (strlen Str)))))
   (t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))
   ))
  Text
)

Считает уклон газопровода в промилле и заменяет мтекст с точностью одного знака после запятой.

(vl-load-com)
(defun c:zod65( / oldMode oldMode_2 zod65_mode_zapyatie sum_dlin tek_dlin flag_1 flag_2 flag_3 cc1 cc2 pt_1 pt_2)
(defun Zoderror (msg)
(vl-cmdf)
(vla-EndUndoMark actdoc)
(setq *error* my_error)
(vl-cmdf "Undo" "" )
)
(setq actdoc (vla-get-activedocument(vlax-get-acad-object)))
(vla-startUndoMark actdoc)
(setq 	my_error	*error*
	*error*		Zoderror
)
(if (or(null zod65_mode_1)(null zod65_Uklon))(zod655))
(setq sum_dlin	0.0 tek_dlin 0.0)
(while (null flag_1)
	(if	(setq cc1(car (entsel "\n Укажите текст/мультвыноску/блок")))
		(if	(member (cdr(assoc 0 (entget cc1)))'("TEXT" "MTEXT" "MULTILEADER" "INSERT"))
			(setq flag_1 t)
		)
	)
)
(if	(equal(assoc 0 (entget cc1))'(0 . "INSERT"))
	(setq cc1(mip_MTEXT_Unformat(vla-get-textstring(car(vlax-safearray->list(vlax-variant-value(vla-GetAttributes (vlax-ename->vla-object cc1 ))))))))
	(setq cc1 (mip_MTEXT_Unformat(vla-get-textstring(vlax-ename->vla-object cc1))))
)
(if (vl-string-search "," cc1)
	(progn
		(setq 	zod65_mode_zapyatie T
				cc1(vl-string-subst "." "," cc1)
		)
	)
)
(setq cc1 (atof cc1))
(setq pt_1(getpoint "\n Укажите точку"))
(if (null pt_1) (setq tek_dlin 0.0 sum_dlin 0.0)
			(while (null flag_2)
				(princ (strcat "\n Текущая длина " (rtos (/ sum_dlin 2) 2 2) "  м"))
				(setq pt_2(getpoint "\n Укажите точку" pt_1))
				(if pt_2
					(setq	tek_dlin (DISTANCE pt_2 pt_1) sum_dlin (+ sum_dlin tek_dlin) pt_1 pt_2 tek_dlin 0.0)
					(setq	flag_2 T)
				)
			)
)
(princ (strcat "\n Текущая длина  " (rtos (/ sum_dlin 2) 2 2) "  м"))
(while (null flag_3)
	(if	(setq cc2(car (entsel "\n Укажите текст/мультвыноску/блок")))
		(if	(member (cdr(assoc 0 (entget cc2)))'("TEXT" "MTEXT" "MULTILEADER" "INSERT"))
			(setq flag_3 t)
		)
	)
)
(if (equal zod65_mode_1 "+")
(setq sum_dlin(rtos (+ cc1 (*(/ sum_dlin 2000)zod65_Uklon)) 2 2 ))
(setq sum_dlin(rtos (- cc1 (*(/ sum_dlin 2000)zod65_Uklon)) 2 2 ))
)
(if (vl-string-search "." sum_dlin)
	(cond	((equal 1 (-(strlen sum_dlin)(vl-string-search "." sum_dlin)1)) (setq sum_dlin(strcat sum_dlin "00")))
			((equal 2 (-(strlen sum_dlin)(vl-string-search "." sum_dlin)1)) (setq sum_dlin(strcat sum_dlin "")))
	)
	(setq sum_dlin(strcat sum_dlin ".000"))
)
(if zod65_mode_zapyatie (setq sum_dlin(vl-string-subst "," "."  sum_dlin)))
(if (not(equal "-"(SUBSTR sum_dlin 1 1)))
	(setq sum_dlin(strcat "" sum_dlin))
)
(if	(equal(assoc 0 (entget cc2))'(0 . "INSERT"))
	(vla-put-textstring(car(vlax-safearray->list(vlax-variant-value(vla-GetAttributes (vlax-ename->vla-object cc2 )))))sum_dlin)
	(vla-put-textstring(vlax-ename->vla-object cc2)sum_dlin)
)
)

(defun zod655( / oldMode oldMode_2)
(defun Zoderror (msg)
(vl-cmdf)
(vla-EndUndoMark actdoc)
(setq *error* my_error)
(vl-cmdf "Undo" "" )
)
(setq actdoc (vla-get-activedocument(vlax-get-acad-object)))
(vla-startUndoMark actdoc)
(setq 	my_error	*error*
	*error*		Zoderror
)

(if(not zod65_mode_1)(setq zod65_mode_1 "+"))
	(initget "+ -")
    (setq oldMode zod65_mode_1 
    zod65_mode_1 
     (getkword
       (strcat "\n Выберите [+/-] <" zod65_mode_1 ">: "))
     ); end setq
	 (if(null zod65_mode_1)(setq zod65_mode_1 oldMode))
(if (and zod65_Uklon (not(equal 'str (type zod65_Uklon))))(setq zod65_Uklon(rtos zod65_Uklon 2 2)))
(if(not zod65_Uklon)(setq zod65_Uklon "0.003"))
	(initget (strcat zod65_Uklon  " Input"))
    (setq oldMode_2 zod65_Uklon 
    zod65_Uklon 
     (getkword
       (strcat "\nSpecify mode [" zod65_Uklon "/Input] <" zod65_Uklon ">: "))
     ); end setq
	 (if(null zod65_Uklon)(setq zod65_Uklon oldMode_2))
	 (if(equal zod65_Uklon  "Input")(setq zod65_Uklon (getreal "Input new value")))
	 (if(null zod65_Uklon)(setq zod65_Uklon 0.000))
	 (if (equal 'str (type zod65_Uklon))(setq zod65_Uklon(atof zod65_Uklon)))
)

(defun c:zod655 ( / )(zod655))

;функция mip_MTEXT_Unformat взята http://kpblc.blogspot.com/2007_06_01_archive.html
(defun mip_mtext_unformat (mtext / text str)
  (setq text "")
  (while (/= mtext "")
    (cond
      ((wcmatch (strcase (setq str (substr mtext 1 2))) "\\[\\{}]")
       (setq mtext (substr mtext 3)
             text  (strcat text str)
             ) ;_ end of setq
       )
      ((wcmatch (substr mtext 1 1) "[{}]") (setq mtext (substr mtext 2)))
      ((wcmatch (strcase (setq str (substr mtext 1 2))) "\\[LO`~]")
       (setq mtext (substr mtext 3))
       )
      ((wcmatch (strcase (substr mtext 1 8)) "\\FSYMBOL")
;;;Add VVA remove Symbol
       (setq mtext (substr mtext (+ 2 (vl-string-search "}" mtext))))
       )
      ((wcmatch (strcase (substr mtext 1 2)) "\\[ACFHQTW]")
       (setq mtext (substr mtext (+ 2 (vl-string-search ";" mtext))))
       )
      ((wcmatch (substr mtext 1 3) "\\p[qxicrjd]")
;;;Add and changed by kpblc
       (setq mtext (substr mtext (+ 2 (vl-string-search ";" mtext))))
       )
      ((wcmatch (strcase (substr mtext 1 2)) "\\P")
       (if (or
             (zerop (strlen text))
             (= " " (substr text (strlen text)))
             (= " " (substr mtext 3 1))
             ) ;_ end of or
         (setq mtext (substr mtext 3))
         (setq mtext (substr mtext 3)
               text  (strcat text " ")
               ) ;_ end of setq
         ) ;_ end of if
       )
      ((wcmatch (strcase (substr mtext 1 2)) "\\S")
       (setq str   (substr mtext 3 (- (vl-string-search ";" mtext) 2))
             text  (strcat text (vl-string-translate "#^\\" "/^\\" str))
             mtext (substr mtext (+ 4 (strlen str)))
             ) ;_ end of setq
       )
      (t
       (setq text  (strcat text (substr mtext 1 1))
             mtext (substr mtext 2)
             ) ;_ end of setq
       )
      ) ;_ end of cond
    ) ;_ end of while
  text
  ) ;_ end of defun
  
(princ "\nФайл zod успешно загружен")

Считает отметки в зависимости от уклона и расстояния по горизонтали в масштабе 1:500 с заменой мтекста с точностью два знака после запятой. Если горизонтальный масштаб другой надо подобрать нужное число в строках
(setq sum_dlin(rtos (+ cc1 (*(/ sum_dlin 2000)zod65_Uklon)) 2 2 ))
(setq sum_dlin(rtos (- cc1 (*(/ sum_dlin 2000)zod65_Uklon)) 2 2 ))
(заменить 2000 на другое). Я делал это опытным путем.
Всем удачи.

vladant · 07.11.2018, 18:18

подниму тему. уважаемый Prodiver писал про уклон в промилле, для себя изменил в мм, но вот что в коде нужно изменить чтобы было округление до тысячных после запятой не смог постичь. прочитал про rtos, но как он здесь работает не пойму...

Код:

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

 (defun c:z-calc-text-value_1 (/ value ent obj)
(vl-load-com)
(princ
"\nВыберите текстовые объекты среди которых будет произведененна калькуляция"
) ;_ end of princ
(setq value
(rtos
(apply
'(lambda (a b c) (/ (abs (* (- a b) 1)) c.))
(mapcar
(function
(lambda (a)
(atof
(vl-string-trim
"%Uu {\\Ll}"
(vl-string-subst
"."
","
(mip_MTEXT_Unformat
(cdr (assoc 1 (entget a)))
) ;_Снос форматирования
) ;_ vl-string-subst
) ;_ vl-string-trim
) ;_ atof
) ;_ lambda
) ;_ function
(mapcar
'(lambda (x / obj)
(princ (strcat "\n" x))
(while
(not
(and (setq obj
(car (entsel (princ (strcat "\r" x))))
) ;_ end of setq
(vl-string-search "TEXT" (cdr (assoc 0 (entget obj))))
) ;_ end of and
) ;_ end of not
) ;_ end of while
obj
) ;_ end of lambda
(list
"Текст А :"
"Текст B :"
"Текст C :"
) ;_ end of list
) ;_ end of mapcar
) ;_ mapcar
) ;_ apply
) ;_ end of rtos
) ;_ end of setq
(if (vl-string-position (ascii ".") value)
(setq value (vl-string-right-trim ".0" value))
) ;_ if

Код
(setq value (vl-string-subst "," "." value))
(princ (strcat "\nРезультат = " value))
(alert (strcat "Результат = " value))
(setvar "ERRNO" 0)
(while
(and (not (setq ent
(car
(nentsel
(strcat
"\n Выберите текстовый объект для записи значения <Выход>:"
) ;_ strcat
) ;_ entsel
) ;_ car
) ;_ setq
) ;_ not
(equal (getvar "ERRNO") 7)
) ;_ and
(setvar "ERRNO" 0)
) ;_ while
(if (and ent
(vlax-property-available-p
(setq obj (vlax-ename->vla-object ent))
'TextString
) ;_ vlax-property-available-p
(vlax-write-enabled-p obj)
) ;_ and
(progn
(vlax-put-property obj 'TextString value)
(vla-put-color obj 7) ;_Цвет текста 7
(vlax-release-object obj)
) ;_ progn
) ;_ if
(princ)
) ;_ defun
(defun mip_MTEXT_Unformat ( Mtext / text Str )
(setq Text "")
(while (/= Mtext "")
(cond
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[\\{}]")
(setq Mtext (substr Mtext 3) Text (strcat Text Str)))
((wcmatch (substr Mtext 1 1) "[{}]")(setq Mtext (substr Mtext 2)))
((wcmatch (strcase (setq Str (substr Mtext 1 2))) "\\[LO`~]")
(setq Mtext (substr Mtext 3)))
((wcmatch (strcase (substr Mtext 1 2)) "\\[ACFHQTW]")
(setq Mtext (substr Mtext (+ 2 (vl-string-search ";" Mtext)))))
((wcmatch (strcase (substr Mtext 1 2)) "\\P")
(if (or(= " " (substr Text (strlen Text)))
(= " " (substr Mtext 3 1)))
(setq Mtext (substr Mtext 3))
(setq Mtext (substr Mtext 3) Text (strcat Text " "))))
((wcmatch (strcase (substr Mtext 1 2)) "\\S")
(setq Str (substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
Text (strcat Text (vl-string-translate "#^\\" "/^\\" Str))
Mtext (substr Mtext (+ 4 (strlen Str)))))
(t (setq Text (strcat Text (substr Mtext 1 1)) Mtext (substr Mtext 2)))
))
Text
)

сильно не пинать, чукча учиться только

1958 · 08.11.2018, 03:09

Цитата:

Сообщение от vladant

прочитал про rtos, но как он здесь работает не пойму...

Найдите:

Код:

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

        ) ;_ end of rtos

и замените на:

Код:

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

 2 3) ;_ end of rtos

3 - это количество разрядов после запятой

iSpawn · 29.05.2020, 11:25

дабы не плодить темы спрошу тут. Нужен ЛИСП для расчёта угла падения угольных пластов, т.е. нужно вместо промилле чтоб выводило градусы.

Krieger · 29.05.2020, 13:19

Цитата:

Сообщение от iSpawn

дабы не плодить темы спрошу тут. Нужен ЛИСП для расчёта угла падения угольных пластов, т.е. нужно вместо промилле чтоб выводило градусы.

Лови:

Код:

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

(defun ppm->grd (ppm)
  (/ (* (atan (/ ppm 1000)) 180) pi)
	 )

iSpawn · 01.06.2020, 08:45

Цитата:

Сообщение от Krieger

Лови:

Код:

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

(defun ppm->grd (ppm)
  (/ (* (atan (/ ppm 1000)) 180) pi)
	 )

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

Кулик Алексей aka kpblc · 01.06.2020, 09:12

_.dimangular ?

iSpawn · 01.06.2020, 09:27

Цитата:

Сообщение от Кулик Алексей aka kpblc

_.dimangular ?

имеются несколько горизонталей с разным уровнем (всё в плане), нужно вычислить угол падения в градусах, а _.dimangular вычисляет угол между отрезками на плоскости.
есть команда CGSLIST но она выдаёт в промилле.

Krieger · 01.06.2020, 09:58

Ну если есть код, который уже все делает в промилле, то осталось только перевести результат в градусы:

Код:

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

(ppm->grd (c:CGSLIST))

(defun ppm->grd (ppm)
  (/ (* (atan (/ ppm 1000)) 180) pi)
	 )

PS Я не знаю, что за команда такая CGSLIST. Код в студию.

----- добавлено через ~2 мин. -----

Цитата:

Сообщение от iSpawn

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

Кстасти, как лисп узнает, какие высоты у горизонталей?

iSpawn · 01.06.2020, 10:34

Цитата:

Сообщение от Krieger

Ну если есть код, который уже все делает в промилле, то осталось только перевести результат в градусы:

Код:

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

(ppm->grd (c:CGSLIST))

(defun ppm->grd (ppm)
  (/ (* (atan (/ ppm 1000)) 180) pi)
	 )

PS Я не знаю, что за команда такая CGSLIST. Код в студию.

----- добавлено через ~2 мин. -----

Кстасти, как лисп узнает, какие высоты у горизонталей?

Я не знаю как код команды открыть, команда из Map3d, также работает в civil3d. Указываешь точку на одной горизонтали и на другой, и в командной строке выводится:
""Первая отметка: 300.00м; вторая отметка: 250.00м; разность отметок: -50.00м
уклон: -700.31‰; откос: -1:1.43; расст. по горизонтали: 71.40м""

Что-то твой лисп не запускается, команда ж для запуска ppm?

Krieger · 01.06.2020, 11:14

Цитата:

Сообщение от iSpawn

Что-то твой лисп не запускается, команда ж для запуска ppm?

Это функция запускаетсяв скобках с параметрами, например "(ppm->grd 700.31)".
У меня нет MAP и Civil. Код от туда вытащить не получится. Я не смогу определить высоты горизонталей, если они на плосокости начерчены (полагаю это только MAP и знает), а значит и вычислить уклон. Если они в 3D, то, впринципе, можно. Тогда нужен пример.

iSpawn · 01.06.2020, 11:50

Цитата:

Сообщение от Krieger

Тогда нужен пример.

каждая линия имеет свой уровень (т.е. высоту)

Krieger · 02.06.2020, 05:42

Пробуй:

Код:

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

 (defun c:uklon (/) (Kr_uklon))
(defun Kr_uklon (/ pt1 pt2 dist1 dist2 dist3 z1 z2 ang)
(setq pt1 (trans (getpoint "Укажи первую отметку: ") 1 0)
      pt2 (trans (getpoint (trans pt1 0 1) "\nУкажи вторую отметку: ") 1 0)
      dist1 (distance pt1 pt2)
      z1 (caddr pt1)
      z2 (caddr pt2)
      dist2 (abs (- z1 z2))
      dist3 (sqrt (- (* dist1 dist1) (* dist2 dist2)))
      ang (/ (* (atan (/ dist2 dist3)) 180) pi)
)
(princ (strcat "Первая отметка: " (rtos z1 2 2) "м; вторая отметка: " (rtos z2 2 2) "м; разность отметок: " (rtos dist2 2 2) "м"))
(princ (strcat "\nуклон: " (rtos ang 2 2) "градусов; расст. по горизонтали: " (rtos dist3 2 2) "м"))
(princ)
  )

Команда - uklon

iSpawn · 02.06.2020, 08:39

Цитата:

Сообщение от Krieger

Пробуй:
Команда - uklon

Шикарно! Спасибо. От неумения в лиспы пришлось пилить формулу в экселе =).
А не будет большой наглость попросить прикрутить еще одну функцию - вычисление среднего из 3х измерений ? Чтоб три раза меряешь, а оно тебе среднее даёт.

Krieger · 02.06.2020, 10:06

Цитата:

Сообщение от iSpawn

Шикарно! Спасибо. От неумения в лиспы пришлось пилить формулу в экселе =).
А не будет большой наглость попросить прикрутить еще одну функцию - вычисление среднего из 3х измерений ? Чтоб три раза меряешь, а оно тебе среднее даёт.

Если правильно понял:

Код:

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

 (defun c:uklon (/) (Kr_uklon))
(defun Kr_uklon (/ pt1 pt2 dist1 dist2 dist3 z1 z2 ang)
  (if (setq pt1 (getpoint "\nУкажи первую отметку: "))
    (if (setq pt2 (getpoint pt1 "\nУкажи вторую отметку: "))
      (progn
	(setq dist1 (distance (trans pt1 1 0) (trans pt2 1 0))
	      z1 (caddr (trans pt1 1 0))
	      z2 (caddr (trans pt2 1 0))
	      dist2 (abs (- z1 z2))
	      dist3 (sqrt (- (* dist1 dist1) (* dist2 dist2)))
	      ang (/ (* (atan (/ dist2 dist3)) 180) pi)
	);setq
	(princ (strcat "\nПервая отметка: " (rtos z1 2 2) "м; вторая отметка: " (rtos z2 2 2) "м; разность отметок: " (rtos dist2 2 2) "м"))
	(princ (strcat "\nуклон: " (rtos ang 2 2) "градусов; расст. по горизонтали: " (rtos dist3 2 2) "м"))
	(princ)
      );progn
  );if
    );if
  );defun

(defun Kr_ugol (n / pt1 pt2 dist1 dist2 dist3 z1 z2 ang)
  (if (setq pt1 (getpoint (strcat "\nУкажи первую отметку " (itoa n) "-го отрезка: ")))
    (if (setq pt2 (getpoint pt1 (strcat "\nУкажи вторую отметку " (itoa n) "-го отрезка: ")))
      (progn
	(setq dist1 (distance (trans pt1 1 0) (trans pt2 1 0))
	      z1 (caddr (trans pt1 1 0))
	      z2 (caddr (trans pt2 1 0))
	      dist2 (abs (- z1 z2))
	      dist3 (sqrt (- (* dist1 dist1) (* dist2 dist2)))
	      ang (/ (* (atan (/ dist2 dist3)) 180) pi)
	      );setq
  ang);progn
      nil
      );if
    nil
    );if
  );defun
      

      

(defun c:sr_uklon (/ ang1 ang2 ang3)
  (if (setq ang1 (Kr_ugol 1))
    (if (setq ang2 (Kr_ugol 2))
      (if (setq ang3 (Kr_ugol 3))
	(princ (strcat "\nСредний уклон из 3-х: " (rtos (/ (+ ang1 ang2 ang3) 3) 2 2) " градусов"))
	(princ (strcat "\nСредний уклон из 2-х: " (rtos (/ (+ ang1 ang2) 2) 2 2) " градусов"))
	);if
      (princ (strcat "\nУклон: " (rtos ang1 2 2) " градусов"))
      );if
    );if
  (princ)
  );defun

Команда "sr_uklon"

iSpawn · 02.06.2020, 13:38

Цитата:

Сообщение от Krieger

Если правильно понял:
Команда "sr_uklon"

Еще раз огромное спасибо. Буду тестировать, но на первый взгляд - то что нужно

Alexander Socad · Регистрация: 30.01.2018

Цитата:

Сообщение от Krieger

Пробуй:

Код:

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

 (defun c:uklon (/) (Kr_uklon))
(defun Kr_uklon (/ pt1 pt2 dist1 dist2 dist3 z1 z2 ang)
(setq pt1 (trans (getpoint "Укажи первую отметку: ") 1 0)
      pt2 (trans (getpoint (trans pt1 0 1) "\nУкажи вторую отметку: ") 1 0)
      dist1 (distance pt1 pt2)
      z1 (caddr pt1)
      z2 (caddr pt2)
      dist2 (abs (- z1 z2))
      dist3 (sqrt (- (* dist1 dist1) (* dist2 dist2)))
      ang (/ (* (atan (/ dist2 dist3)) 180) pi)
)
(princ (strcat "Первая отметка: " (rtos z1 2 2) "м; вторая отметка: " (rtos z2 2 2) "м; разность отметок: " (rtos dist2 2 2) "м"))
(princ (strcat "\nуклон: " (rtos ang 2 2) "градусов; расст. по горизонтали: " (rtos dist3 2 2) "м"))
(princ)
  )

Команда - uklon

Добрый день! может кто нибудь помочь сделать так, что бы уклоны выдавался в промилле? с лиспами не очень, у самого не получается

Vladimir_Sergeevich · 02.06.2021, 06:07

Цитата:

Сообщение от Alexander Socad

10
******ang (/ (* (atan (/ dist2 dist3)) 180) pi)

ang (* (/ (abs (- z1 z2)) dist3) 1000)

Цитата:

Сообщение от Alexander Socad

(strcat "\nуклон: " (rtos ang 2 2) "градусов; расст. по горизонтали: " (rtos dist3 2 2) "м")

(strcat "\nуклон: " (rtos ang 2 2) "‰; расст. по горизонтали: " (rtos dist3 2 2) "м")

Alexander Socad · 02.06.2021, 10:09

Цитата:

Сообщение от Vladimir_Sergeevich

ang (* (/ (abs (- z1 z2)) dist3) 1000)

(strcat "\nуклон: " (rtos ang 2 2) "‰; расст. по горизонтали: " (rtos dist3 2 2) "м")

Спасибо огромное!!! Все работает)))

14.11.2005, 09:30		#1
Нужен лисп, который высчитывает уклон линии ВоваН Дороги, Конструкции, Тоннели Сочи Регистрация: 20.05.2004 Сообщений: 102 Нужен лисп, который высчитывает уклон линии. Берем у выделенной линии Delta X, Delta Y и производим следующую операцию: (Delta Y / Delta X)*1000 Результат выводим в командную строку. Спасибо
Просмотров: 34335