Простановка длин полилиний и отрезков в средней точке

Ingpro · 23.10.2023, 12:32

https://www.caduser.ru/forum/topic33096.html
Есть лисп "Простановка длин полилиний"
Длины полилиний с наклоном проставляет "вверх ногами". Это можно откорректировать?
И если не сложно добавить в код и выбор отрезков.

Код:

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

 (defun C:PNT1
       (/ *Error* *Debug* acsp adoc ang axss len otxt pt ss txt)
  (vl-load-com)
  ;=================================================;
  (defun *Error* (msg)
    (cond ((not msg))
      ((member msg '("Function cancelled" "quit / exit abort")))
      ((princ (strcat "\nError: " msg))
       (cond (*Debug* (vl-bt)))
      )
    )
    (vla-endundomark
      (vla-get-activedocument (vlax-get-acad-object))
    )
  )
  ;=================================================;
  (defun alg-ang (obj pnt)
    (angle '(0. 0. 0.)
       (vlax-curve-getfirstderiv
         obj
         (vlax-curve-getparamatpoint
           obj
           pnt
         )
       )
    )
  )
  ;=================================================;
  (or adoc
      (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  )
  (or acsp
      (setq acsp
         (if (or (= (getvar "TILEMODE") 1)
             (> (getvar "CVPORT") 1)
         )
           (vla-get-modelspace adoc)
           (vla-get-paperspace adoc)
         )
      )
  )
  (vla-startundomark
    adoc
  )
  (if (< (atof (getvar "ACADVER")) 15.02)
    (progn
      (alert
    "Для работы программы требуется\nАвтоКАД версии 2000 и выше"
      )
      (exit)
      (princ)
    )
  )
  (prompt "\n\t***\tВыбрать полилинии для простановки длины\t***\n")
  (if (setq ss (ssget (list (cons 0 "*POLYLINE"))))
      (progn
      (setq axss (vla-get-activeselectionset adoc))
      (vlax-for    a axss
    (setq
      len (vlax-curve-getdistatparam a (vlax-curve-getendparam a))
    )
    (setq pt (vlax-curve-getpointatparam
           a
           (/ (vlax-curve-getendparam a) 2.0)
         )
    )
    (setq otxt (vlax-invoke
            acsp
            'AddText
            (rtos len 2 2)
            pt
            (getvar "dimtxt");|<--можно указать вместо конкретную высоту текста|;
          )
    )
    (setq ang (alg-ang a pt))
    (vlax-put otxt 'Rotation ang)
    (vlax-put otxt 'Alignment 13)
    (vlax-put otxt 'TextalignmentPoint pt)
    (vla-update otxt)
      )
    )
    (alert "Ничего не выбрано.Повторить")
  )
  (vla-endundomark
    adoc
  )
  (*Error* nil)
  (princ)
)
(prompt "\n\t***\tУтилита образмеривания полилиний загружена\t***\n")
(prompt "\t***\tВведите в командной строке PNT для выполнения\t***\n")
(princ)
;; TesT : (C:PNT)

koMon · 26.10.2023, 15:06

отрезки + угол текста

Код:

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

 (defun C:PNT1
       (/ *Error* *Debug* acsp adoc ang axss len otxt pt ss txt)
  (vl-load-com)
  ;=================================================;
  (defun *Error* (msg)
    (cond ((not msg))
      ((member msg '("Function cancelled" "quit / exit abort")))
      ((princ (strcat "\nError: " msg))
       (cond (*Debug* (vl-bt)))
      )
    )
    (vla-endundomark
      (vla-get-activedocument (vlax-get-acad-object))
    )
  )
  ;=================================================;
  (defun alg-ang (obj pnt / _angle)
    (if (and (> (setq _angle (angle '(0. 0. 0.)
				       (vlax-curve-getfirstderiv
				         obj
				         (vlax-curve-getparamatpoint
				           obj
				           pnt
				         )
				       )
			    )
		) (* 0.5 pi))
	     (<= _angle (* 1.5 pi))
	)
	(+ pi _angle)
      	_angle
    )  
  )
  ;=================================================;
  (or adoc
      (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  )
  (or acsp
      (setq acsp
         (if (or (= (getvar "TILEMODE") 1)
             (> (getvar "CVPORT") 1)
         )
           (vla-get-modelspace adoc)
           (vla-get-paperspace adoc)
         )
      )
  )
  (vla-startundomark
    adoc
  )
  (if (< (atof (getvar "ACADVER")) 15.02)
    (progn
      (alert
    "Для работы программы требуется\nАвтоКАД версии 2000 и выше"
      )
      (exit)
      (princ)
    )
  )
  (prompt "\n\t***\tВыбрать полилинии для простановки длины\t***\n")
  (if (setq ss (ssget (list (cons 0  "line,*[yp]line"))))
      (progn
      (setq axss (vla-get-activeselectionset adoc))
      (vlax-for    a axss
    (setq
      len (vlax-curve-getdistatparam a (vlax-curve-getendparam a))
    )
    (setq pt (vlax-curve-getpointatparam
           a
           (/ (vlax-curve-getendparam a) 2.0)
         )
    )
    (setq otxt (vlax-invoke
            acsp
            'AddText
            (rtos len 2 2)
            pt
            (getvar "dimtxt");|<--можно указать вместо конкретную высоту текста|;
          )
    )
    (setq ang (alg-ang a pt))
    (vlax-put otxt 'Rotation ang)
    (vlax-put otxt 'Alignment 13)
    (vlax-put otxt 'TextalignmentPoint pt)
    (vla-update otxt)
      )
    )
    (alert "Ничего не выбрано.Повторить")
  )
  (vla-endundomark
    adoc
  )
  (*Error* nil)
  (princ)
)
(prompt "\n\t***\tУтилита образмеривания полилиний загружена\t***\n")
(prompt "\t***\tВведите в командной строке PNT для выполнения\t***\n")
(princ)

Ingpro · 27.10.2023, 10:51

koMon, спасибо большое, как всегда всё отлично работает!!!

1958 · 27.10.2023, 18:24

Чисто для отрезков:

Код:

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

 ;;;подпись длина/угол набора отрезков
;;; http://geodesist.ru/members/1958.30261/
;;; 08.05.2023г.
(DEFUN C:1958_SSLA (/ *ERROR* SMP ENT_0 ENT_8 ENT_62 ENT_370 SS_OBJ LEN_SS_OBJ I OBJ LEN_OBJ ANG_OBJ PT ANG_PT STR)
  (VL-LOAD-COM)
  (DEFUN *ERROR* (MSG)
    (IF (NOT (WCMATCH (STRCASE MSG T) "*break,*cancel*,*exit*"))
      (PRINC (STRCAT "\nError: " MSG))
    )
    (REDRAW)
    (PRINC)
  )
  (SETQ SMP   (ENTGET (CAR (ENTSEL "Укажите образец отрезка >")))
        ENT_0 (CDR (ASSOC 0 SMP))

  )
  (IF (= ENT_0 "LINE")
    (PROGN
      (SETQ ENT_6   (CDR (ASSOC 6 SMP)) ; тип линии
            ENT_8   (CDR (ASSOC 8 SMP)) ; слой
            ENT_62  (CDR (ASSOC 62 SMP)) ; цвет
            ENT_370 (CDR (ASSOC 370 SMP)) ; вес
      )
      (IF (= ENT_6 NIL)
        (SETQ ENT_6 "BYLAYER")
      )
      (IF (= ENT_62 NIL)
        (SETQ ENT_62 256)
      )
      (IF (= ENT_370 NIL)
        (SETQ ENT_370 -1)
      )
      (SETQ SS_OBJ     (SSGET "_X"
                              (LIST (CONS 0 ENT_0)
                                    (CONS 6 ENT_6)
                                    (CONS 8 ENT_8)
                                    (CONS 62 ENT_62)
                                    (CONS 370 ENT_370)
                              )
                       )
            LEN_SS_OBJ
                       (SSLENGTH SS_OBJ)
            I
                       0
      )
      (WHILE (< I
                LEN_SS_OBJ
             )
        (SETQ OBJ (VLAX-ENAME->VLA-OBJECT (CDR (CAR (ENTGET (SSNAME SS_OBJ I))))))
        (SETQ LEN_OBJ (VLA-GET-LENGTH OBJ)
              ANG_OBJ (VLA-GET-ANGLE OBJ)
              PT      (VLAX-CURVE-GETPOINTATDIST OBJ (/ LEN_OBJ 2))
        )
        (IF (> (* PI 1.5) ANG_OBJ (* PI 0.5))
          (SETQ ANG_PT (+ ANG_OBJ PI))
          (SETQ ANG_PT ANG_OBJ)
        )
        (SETQ STR
               (STRCAT (RTOS LEN_OBJ 2 2) "\n" (VL-STRING-SUBST "%%d" "d" (ANGTOS ANG_OBJ 1 3)))
        )

        (ENTMAKEX (LIST (CONS 0 "MTEXT")
                        (CONS 100 "AcDbEntity")
                        (CONS 100 "AcDbMText")
                        (CONS 8 ENT_8)
                        (CONS 62 ENT_62)
                        (CONS 10 PT)
                        (CONS 1 STR)
                        (CONS 50 ANG_PT)
                        (CONS 71 5)
                        (CONS 72 5)
                  )
        )
        (SETQ I (1+ I))
      )
      (ALERT (STRCAT "Подписано отрезков: " (ITOA I) " шт."))
    )
    (VL-EXIT-WITH-ERROR (ALERT "Это не отрезок!"))
  )
  (PRINC)
)

Ingpro · 27.10.2023, 18:31

Цитата:

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

Чисто для отрезков:

1958, спасибо! Нужная программа...

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Нужна помощь в написании autolisp. Autocad2021 Суммы длин и площадей полилиний в тексты по слоям	inatsvin	Поиск исполнителей	0	10.02.2022 10:21
Какой язык перспективен для инженера-конструктора с условием	The_Mercy_Seat	Программирование	705	17.03.2021 14:19
Как «заставить» AutoCad 2011 выдать таблицу с параметрами длин и углов заданных отрезков?	HellFistula	AutoCAD	4	12.03.2018 14:02
Автоматизировать подсчет суммы длин отрезков по определенному слою? Возможно ли?	nikolakrg	Программирование	11	26.10.2012 17:20
LISP. Программа сопряжения отдельных сегментов полилиний или отрезков без объединения	Profan	Готовые программы	20	30.03.2010 18:23