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

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Можно ли автоматически проставить на полилинии размеры?

Можно ли автоматически проставить на полилинии размеры?

Ответ
Поиск в этой теме
Непрочитано 02.12.2005, 08:00 #1
Можно ли автоматически проставить на полилинии размеры?
B2Slow
 
Иркутск
Регистрация: 20.06.2005
Сообщений: 57

Нужно автоматически проставить размер линий или сегментов полилинии Aligned Dimension-ом с привязкой к центру сегмента, выделяя сразу несколько полилиний или линий.
Просмотров: 15976
 
Непрочитано 02.12.2005, 10:00
#2
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,392


Можно. Примерно так:
Код:
[Выделить все]
(defun C:PlMDim (/ par dim pts)
  (prompt "\nSelect Polylines: ") 
  (ssget) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
        ass (vla-get-ActiveSelectionSet adoc)
        csp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item ass 0))))
  (vlax-for ent ass
    (if (= (vla-get-objectname ent) "AcDbPolyline")
      (progn (setq par (- (vlax-curve-getParamAtPoint ent (vlax-curve-getEndPoint ent)) 0.5))
        (while (> par 0.5)
          (setq pts (mapcar '(lambda (x) (vlax-3d-point (vlax-curve-getPointAtParam ent x)))
                    (list par (1- par) (fix par)))
              par (1- par));setq
        (if pts (progn (setq dim (vla-addDimAligned csp (car pts) (cadr pts) (last pts)))
                  (mapcar '(lambda (x y) (vlax-put-property dim x y))
              '(TextInsideAlign VerticalTextPosition) (list 0 acAbove)))));while
    ));if
  );vlax-for
);end
Размерный текст получаются выровненным над размерной линией. Только вот место размерного текста отлаживается вручную. потому как корявость полилинии - параметр неизвестный.
Лентяй вне форума  
 
Автор темы   Непрочитано 02.12.2005, 11:48
#3
B2Slow


 
Регистрация: 20.06.2005
Иркутск
Сообщений: 57


аааа.. Лентяй, я имел в виду привязку текста размера, а не привязку размерных точек.. выразился непонятно, к сожалению..
Нужно что-то типа
Код:
[Выделить все]
^C^C_dimaligned ;
, только сразу к нескольким объектам (линиям/полилиниям) в т.ч. сегментам полилинии.
А это будет работать в пользовательских ПСК?
B2Slow вне форума  
 
Непрочитано 02.12.2005, 12:08
#4
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,392


Тогда непонятна сама проблема, потому как при построении любого размера, что прямого, что выраненного (aligned), техст автоматом встает посередине линий-выносок. Все остальное достигается соответсвующей настройкой стиля. Впрочем, попробуй такую прогу
Код:
[Выделить все]
(defun C:PlMDim (/ par dim pts)
  (prompt "\nSelect Polylines: ") 
  (ssget) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
        ass (vla-get-ActiveSelectionSet adoc)
        csp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item ass 0))))
  (vlax-for ent ass
    (if (= (vla-get-objectname ent) "AcDbPolyline")
      (progn (setq par (vlax-curve-getParamAtPoint ent (vlax-curve-getEndPoint ent)))
        (while (> par 0)
          (setq pts (mapcar '(lambda (x) (vlax-3d-point (vlax-curve-getPointAtParam ent x)))
                    (list par (1- par) (fix par)))
              par (1- par));setq
        (if pts (progn (setq dim (vla-addDimAligned csp (car pts) (cadr pts) (last pts)))
                  (mapcar '(lambda (x y) (vlax-put-property dim x y))
              '(TextInsideAlign VerticalTextPosition) (list 0 acAbove)))));while
    ));if
  );vlax-for
);end
Лентяй вне форума  
 
Автор темы   Непрочитано 02.12.2005, 12:18
#5
B2Slow


 
Регистрация: 20.06.2005
Иркутск
Сообщений: 57


Вот-вот-вот, то что нужно!!.. Проблема была в том, чтобы поставить размер на все сегменты одновременно, а про привязку текста я для сведения сказал. Лентяй, ну пожалуйста, еще одно усилие.. А обычные line можно сюда же?..
Для вас профессионалов-магистров это просто разминка, а для обычных смертных это порядковое сокращение рутинной работы...:roll: Спасибо.
B2Slow вне форума  
 
Непрочитано 02.12.2005, 12:41
#6
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,392


Цитата:
B2Slow: А обычные line можно сюда же?..
Послушайте, B2Slow, вам кто-нибудь говорил, что вы - зануда?
Цитата:
Для вас профессионалов-магистров это просто разминка, а для обычных смертных это порядковое сокращение рутинной работы...
И льстец? Ну да ладно. держите очередной апгрейд, ибо добр аз есмь днесь.
Код:
[Выделить все]
(defun C:PlMDim (/ par dim pts)
  (prompt "\nSelect Polylines: ") 
  (ssget) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
        ass (vla-get-ActiveSelectionSet adoc)
        csp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item ass 0))))
  (vlax-for ent ass
    (cond ((= (vla-get-objectname ent) "AcDbPolyline")
           (setq par (vlax-curve-getParamAtPoint ent (vlax-curve-getEndPoint ent)))
           (while (> par 0)
             (setq pts (mapcar '(lambda (x) (vlax-3d-point (vlax-curve-getPointAtParam ent x)))
                          (list par (1- par) (- par 0.5)))
                   par (1- par));setq
             (if pts (progn (setq dim (vla-addDimAligned csp (car pts) (cadr pts) (last pts)))
                  (mapcar '(lambda (x y) (vlax-put-property dim x y))
              '(TextInsideAlign VerticalTextPosition) (list 0 acAbove))))));PLine
          ((= (vla-get-objectname ent) "AcDbLine")
           (setq pts (mapcar '(lambda (x) (vlax-get-property ent x))
                       '(StartPoint EndPoint))
                 dim (vla-addDimAligned csp (car pts) (cadr pts) (last pts)))
           (mapcar '(lambda (x y) (vlax-put-property dim x y))
              '(TextInsideAlign VerticalTextPosition) (list 0 acAbove)));Line
    );cond
  );vlax-for
);end
Лентяй вне форума  
 
Автор темы   Непрочитано 02.12.2005, 12:52
#7
B2Slow


 
Регистрация: 20.06.2005
Иркутск
Сообщений: 57


Цитата:
Сообщение от Лентяй
Цитата:
B2Slow: А обычные line можно сюда же?..
Послушайте, B2Slow, вам кто-нибудь говорил, что вы - зануда?
Цитата:
Для вас профессионалов-магистров это просто разминка, а для обычных смертных это порядковое сокращение рутинной работы...
И льстец? Ну да ладно. держите очередной апгрейд, ибо добр аз есмь днесь.
Да не зануда мы и не льстец.. Мы это сразу в "техзадании" изложил))).. Я ж не могу доделать это сам..
И "профессионал" у вас под ником стоит, чему я не имею причин не верить..
Спасибо. Теперь мы можем быть счастлив..
B2Slow вне форума  
 
Непрочитано 02.12.2005, 12:55
#8
asys

архитектор
 
Регистрация: 10.08.2005
Ростов-на-Дону
Сообщений: 5,251


>Лентяй
Круто, я тоже заценил. А можно для меня чтоб с отступом от измеряемой линии на высоту тексата + 2 смещения текста от размерной линии. Мне на плане размеры помещений проставлять 8) Плиз-з-з
asys вне форума  
 
Непрочитано 02.12.2005, 12:59
#9
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,392


Как писала А. Ахматова, "В очередь. суки, в очередь!" Имейте совесть, у меня уже 2 часа ночи! Вот выйду с утреца на службу. там и накатаю.
Лентяй вне форума  
 
Непрочитано 02.12.2005, 13:01
#10
asys

архитектор
 
Регистрация: 10.08.2005
Ростов-на-Дону
Сообщений: 5,251


А у нас обед (13:02 по москве)
asys вне форума  
 
Непрочитано 02.12.2005, 14:36
#11
fixo

Lisp/VBA/VB.NET Hobbyist
 
Регистрация: 24.03.2005
Славен Град Петров
Сообщений: 367


Цитата:
Сообщение от Asys
А у нас обед (13:02 по москве)
;;;Еще одна программа тоже близко к данной теме:
;;;образмеривает замкнутые полилинии (вынос размерной линии
;;;нужно изменить в зависимости от единиц рисования)
;;;Без проверок на замкнутость и замороженный слой
;;;____________________
;;;А2005, Windows XP

Код:
[Выделить все]
;; Program draw a dimension of all polygon segments
;; Polygon must be closed
;; Copyrights (c) 2005 Fatty T.O.H.
;; All rights removed


;; helper function: written by Luis Esquivel 
;; get coordinates
;; ***  координаты полилинии  ***
(defun get_vertices (obj / i verts)
  (setq i (1- (vlax-curve-getendparam obj)))
  (while (>= i 0)
    (setq verts	(cons (vlax-curve-getpointatparam obj i) verts)
	  i	(1- i)
    )
  )
  verts
)

;; helper function: written by Fatty T.O.H.

;; ***  разность двух углов  ***
(defun dif-angle (ang1 ang2 / def)
  (set 'ang1
       (if (> ang2 (+ pi ang1))
	 (+ (* pi 2) ang1)
	 ang1
       )
  )
  (set 'ang2
       (if (> ang1 (+ pi ang2))
	 (+ (* pi 2) ang2)
	 ang2
       )
  )
  (setq def (- ang2 ang1))
)
;; helper function: written by Fatty T.O.H.

;; ***  проверка на направление полилинии  ***
;; возвращает Т если полилиния нарисована против
;; часовой стрелки (angdir=0)
(defun ccw-test	(pt_list / angle_list)
  (setq	angle_list
	 (mapcar (function (lambda (x y)
			     (angle x y)
			   )
		 )
		 pt_list
		 (cdr pt_list)
	 )
  )
  (if (> (apply	'+
		(mapcar	(function (lambda (x y) (dif-angle x y)))
			angle_list
			(cdr angle_list)
		)
	 )
	 0
      )
    t
    nil
  )
)
;; ***  основная программа  ***

(defun C:dmp (/ acsp adoc cent_coords coords pl txt_coords)
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (setq acsp (vla-get-modelspace adoc))
  (setq	pl (vlax-ename->vla-object
	     (car (entsel "\nУказать замкнутую полилинию \n"))
	   )
  )
  (if (eq :vlax-false (vla-get-closed pl))
    (progn
      (alert "Контур незамкнут\n
      \t Выход")(exit)))
  (setq	coords (get_vertices pl)
	coords (append coords (list (car coords)))
  )
  (if (ccw-test coords)(setq dop pi)(setq dop 0)) 
  (setq	cent_coords
	 (mapcar (function (lambda (x y)
			     (mapcar '/ (mapcar '+ x y) '(2 2 2))
			   )
		 )
		 coords
		 (cdr coords)
	 )
  )
  (setq	txt_coords
	 (mapcar (function (lambda (x y z)
			     (polar x (+ dop (angle y z) (/ pi 2)) 8.);вынос размерной линии изменить
			   )
		 )
		 cent_coords
		 coords
		 (cdr coords)
	 )
  )
  (mapcar (function (lambda (x y z)
		      (vla-adddimaligned acsp x y z)
		    )
	  )
	  (mapcar 'vlax-3d-point coords)
	  (mapcar 'vlax-3d-point (cdr coords))
	  (mapcar 'vlax-3d-point txt_coords)
  )
  (princ)
)

(prompt "\n\t***\tОБРАЗМЕРИВАНИЕ ЗАМКНУТЫХ ПОЛИГОНОВ\t***\n")
(prompt "\nНабери в командной строке DMP для выполнения команды\n")

;TesT:
;(C:dmp)(princ)
fixo вне форума  
 
Непрочитано 02.12.2005, 14:53
#12
asys

архитектор
 
Регистрация: 10.08.2005
Ростов-на-Дону
Сообщений: 5,251


>Fatty
Спасибо, жаль что только для замкнутых контуров
asys вне форума  
 
Непрочитано 02.12.2005, 23:20
#13
Лентяй

Project Engineer
 
Регистрация: 05.01.2005
Лос Анджелес
Сообщений: 1,392


Asys, держите вашу прогу. Пришлось изменить почти всю логику и провозиться пару часов. Пользуйтесь и не забывайте утренне и нощно сугубо и трегубо благодарить меня за то, что я есть.
Код:
[Выделить все]
(defun C:PlMDim (/ par dim pts dpt wpt tpt dpts) 
  (prompt "\nSelect Polylines: ") 
  (ssget) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
        ass (vla-get-ActiveSelectionSet adoc) 
        csp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item ass 0)))
	dvr (mapcar 'getvar '("DIMTXT" "DIMSCALE" "DIMGAP"))
	ofs (+ (* (car dvr) (cadr dvr)) (* (last dvr) 2)))
  (vlax-for ent ass 
    (setq par (vlax-curve-getParamAtPoint ent (vlax-curve-getEndPoint ent)))
    (cond ((= (vla-get-objectname ent) "AcDbPolyline") (setq pl t)
	   (while (> par 0) (setq pt (reverse
		(cons (vlax-curve-getFirstDeriv ent (- par 0.5))
		      (reverse (mapcar '(lambda (x) (vlax-curve-getPointAtParam ent x))
				       (list par (1- par) (- par 0.5)))))));setq
	       (if (null pts) (setq pts (list pt)) (setq pts (cons pt pts)));if
	     (setq par (1- par))));PLine
	  ((= (vla-get-objectname ent) "AcDbLine") (setq pl nil)
           (setq pt (vlax-curve-getPointAtParam ent (/ par 2))
		 pts (reverse (cons (vlax-curve-getFirstDeriv ent (- par 0.5))
				    (cons pt (mapcar '(lambda (x) (vlax-get ent x))
					      '(StartPoint EndPoint)))))));Line
	  (t (alert "\Wrong Selection!")));cond
    (while pts (setq dpt (last (setq wpt (if pl (car pts) pts)))
		     tpt (polar (caddr wpt) (+ (atan (/ (cadr dpt) (car dpt))) 0.785398) ofs)
		     dpts (mapcar 'vlax-3d-point (subst tpt (caddr wpt) wpt))
		     dim (vla-addDimAligned csp (car dpts) (cadr dpts) (caddr dpts)));setq
      (mapcar '(lambda (x y) (vlax-put-property dim x y))
              '(TextInsideAlign VerticalTextPosition) (list 0 acAbove))
      (setq pts (if pl (cdr pts) nil)));while 
  );vlax-for 
);end
Лентяй вне форума  
 
Непрочитано 03.12.2005, 09:25
#14
fixo

Lisp/VBA/VB.NET Hobbyist
 
Регистрация: 24.03.2005
Славен Град Петров
Сообщений: 367


Цитата:
Сообщение от Asys
>Fatty
Спасибо, жаль что только для замкнутых контуров
По просьбе трудящихся:

Код:
[Выделить все]
;; Program draw a dimension of all polygon segments
;; Polygon must be closed or opened
;; copyrights (c) 2005 Fatty T.O.H. all rights removed
;; (freeware)
;; A2005 Windows XP


;; helper functions : written by Fatty T.O.H.

;; ***  группировка списка   ***

(defun group-by-num (lst num / ls ret)
  (if (= (rem (length lst) num ) 0)
    (progn
      (setq ls nil)
      (repeat (/ (length lst) num)
	(repeat num (setq ls 
		    (cons (car lst) ls)
	      lst (cdr lst)))
	(setq ret (append ret (list (reverse ls)))
	      ls nil)))
    )
ret
  )

;; ***  координаты полилинии  ***

(defun get-vexs (pline_obj / verts)
      (setq verts (vlax-get pline_obj 'Coordinates)
	    verts
		  (cond
		    ((wcmatch (vlax-get pline_obj 'Objectname )
			     "AcDb2dPolyline,AcDb3dPolyline") 
		     (group-by-num verts 3)
		    )
		    ((eq (vlax-get pline_obj 'Objectname )
			     "AcDbPolyline") 
		     (group-by-num verts 2)
		    )
		    (T nil)
		  )
)
  ) 


;; ***  разность двух углов  ***

(defun dif-angle (ang1 ang2 / def)
  (set 'ang1
       (if (> ang2 (+ pi ang1))
	 (+ (* pi 2) ang1)
	 ang1
       )
  )
  (set 'ang2
       (if (> ang1 (+ pi ang2))
	 (+ (* pi 2) ang2)
	 ang2
       )
  )
  (setq def (- ang2 ang1))
)

;; ***  проверка на направление полилинии  ***
;; возвращает Т если полилиния нарисована против
;; часовой стрелки (angdir=0)
(defun ccw-test	(pt_list / angle_list)
  (setq	angle_list
	 (mapcar (function (lambda (x y)
			     (angle x y)
			   )
		 )
		 pt_list
		 (cdr pt_list)
	 )
  )
  (if (> (apply	'+
		(mapcar	(function (lambda (x y) (dif-angle x y)))
			angle_list
			(cdr angle_list)
		)
	 )
	 0
      )
    t
    nil
  )
)
;; ***  основная программа  ***

(defun C:dmp (/ acsp adoc cent_coords coords pl txt_coords)
  (vl-load-com)
  (setq adoc (vla-get-activedocument (vlax-get-acad-object)))
  (setq acsp (vla-get-modelspace adoc))
  (setq	pl (vlax-ename->vla-object
	     (car (entsel "\nУказать замкнутую полилинию \n"))
	   )
  )
  
  (setq	coords (get-vexs pl))
  (if (eq :vlax-true (vla-get-closed pl))
  (setq	coords (append coords (list (car coords)))))
  (if (ccw-test coords)(setq dop pi)(setq dop 0)) 
  (setq	cent_coords
	 (mapcar (function (lambda (x y)
			     (mapcar '/ (mapcar '+ x y) '(2 2 2))
			   )
		 )
		 coords
		 (cdr coords)
	 )
  )
  (setq	txt_coords
	 (mapcar (function (lambda (x y z)
			     (polar x (+ dop (angle y z) (/ pi 2)) 8.);вынос размерной линии изменить
			   )
		 )
		 cent_coords
		 coords
		 (cdr coords)
	 )
  )
  (mapcar (function (lambda (x y z)
		      (vla-adddimaligned acsp x y z)
		    )
	  )
	  (mapcar 'vlax-3d-point coords)
	  (mapcar 'vlax-3d-point (cdr coords))
	  (mapcar 'vlax-3d-point txt_coords)
  )
  (princ)
)

(prompt "\n\t***\tОБРАЗМЕРИВАНИЕ ПОЛИГОНОВ\t***\n")
(prompt "\nНабери в командной строке DMP для выполнения команды\n")

;TesT:
;;;(repeat 16
;;;  (C:dmp)
;;;  (princ))
fixo вне форума  
 
Непрочитано 03.12.2005, 11:40
#15
asys

архитектор
 
Регистрация: 10.08.2005
Ростов-на-Дону
Сообщений: 5,251


>Лентяй
>Fatty
[sm206]
Большой спасиба
asys вне форума  
 
Непрочитано 03.12.2005, 14:27
#16
fixo

Lisp/VBA/VB.NET Hobbyist
 
Регистрация: 24.03.2005
Славен Град Петров
Сообщений: 367


Цитата:
Сообщение от Asys
>Лентяй
>Fatty
[sm206]
Большой спасиба
Спасибо за пиво

Fatty :P
fixo вне форума  
 
Непрочитано 03.12.2005, 14:39
#17
asys

архитектор
 
Регистрация: 10.08.2005
Ростов-на-Дону
Сообщений: 5,251


Мне не жалко :P
[ATTACH]1133609957.jpg[/ATTACH]
asys вне форума  
 
Непрочитано 25.05.2008, 18:42
#18
AZIA


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


не подумайте обо мне плохого но что делать с этими кодами?
AZIA вне форума  
 
Непрочитано 25.05.2008, 23:56
#19
Кулик Алексей aka kpblc
Moderator

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


dwg.ru/art/8
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 25.05.2019, 21:34 Сделайте пожалуйста чтоб можно было редактировать размер :flirt:
#20
TanyaMJ


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


Цитата:
Сообщение от Лентяй Посмотреть сообщение
Asys, держите вашу прогу. Пришлось изменить почти всю логику и провозиться пару часов. Пользуйтесь и не забывайте утренне и нощно сугубо и трегубо благодарить меня за то, что я есть.
Код:
[Выделить все]
(defun C:PlMDim (/ par dim pts dpt wpt tpt dpts) 
  (prompt "\nSelect Polylines: ") 
  (ssget) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
        ass (vla-get-ActiveSelectionSet adoc) 
        csp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item ass 0)))
	dvr (mapcar 'getvar '("DIMTXT" "DIMSCALE" "DIMGAP"))
	ofs (+ (* (car dvr) (cadr dvr)) (* (last dvr) 2)))
  (vlax-for ent ass 
    (setq par (vlax-curve-getParamAtPoint ent (vlax-curve-getEndPoint ent)))
    (cond ((= (vla-get-objectname ent) "AcDbPolyline") (setq pl t)
	   (while (> par 0) (setq pt (reverse
		(cons (vlax-curve-getFirstDeriv ent (- par 0.5))
		      (reverse (mapcar '(lambda (x) (vlax-curve-getPointAtParam ent x))
				       (list par (1- par) (- par 0.5)))))));setq
	       (if (null pts) (setq pts (list pt)) (setq pts (cons pt pts)));if
	     (setq par (1- par))));PLine
	  ((= (vla-get-objectname ent) "AcDbLine") (setq pl nil)
           (setq pt (vlax-curve-getPointAtParam ent (/ par 2))
		 pts (reverse (cons (vlax-curve-getFirstDeriv ent (- par 0.5))
				    (cons pt (mapcar '(lambda (x) (vlax-get ent x))
					      '(StartPoint EndPoint)))))));Line
	  (t (alert "\Wrong Selection!")));cond
    (while pts (setq dpt (last (setq wpt (if pl (car pts) pts)))
		     tpt (polar (caddr wpt) (+ (atan (/ (cadr dpt) (car dpt))) 0.785398) ofs)
		     dpts (mapcar 'vlax-3d-point (subst tpt (caddr wpt) wpt))
		     dim (vla-addDimAligned csp (car dpts) (cadr dpts) (caddr dpts)));setq
      (mapcar '(lambda (x y) (vlax-put-property dim x y))
              '(TextInsideAlign VerticalTextPosition) (list 0 acAbove))
      (setq pts (if pl (cdr pts) nil)));while 
  );vlax-for 
);end
TanyaMJ вне форума  
 
Непрочитано 25.08.2022, 18:29
#21
NemoSUN


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


Цитата:
Сообщение от Лентяй Посмотреть сообщение
Asys, держите вашу прогу. Пришлось изменить почти всю логику и провозиться пару часов. Пользуйтесь и не забывайте утренне и нощно сугубо и трегубо благодарить меня за то, что я есть.
Код:
[Выделить все]
(defun C:PlMDim (/ par dim pts dpt wpt tpt dpts) 
  (prompt "\nSelect Polylines: ") 
  (ssget) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
        ass (vla-get-ActiveSelectionSet adoc) 
        csp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item ass 0)))
	dvr (mapcar 'getvar '("DIMTXT" "DIMSCALE" "DIMGAP"))
	ofs (+ (* (car dvr) (cadr dvr)) (* (last dvr) 2)))
  (vlax-for ent ass 
    (setq par (vlax-curve-getParamAtPoint ent (vlax-curve-getEndPoint ent)))
    (cond ((= (vla-get-objectname ent) "AcDbPolyline") (setq pl t)
	   (while (> par 0) (setq pt (reverse
		(cons (vlax-curve-getFirstDeriv ent (- par 0.5))
		      (reverse (mapcar '(lambda (x) (vlax-curve-getPointAtParam ent x))
				       (list par (1- par) (- par 0.5)))))));setq
	       (if (null pts) (setq pts (list pt)) (setq pts (cons pt pts)));if
	     (setq par (1- par))));PLine
	  ((= (vla-get-objectname ent) "AcDbLine") (setq pl nil)
           (setq pt (vlax-curve-getPointAtParam ent (/ par 2))
		 pts (reverse (cons (vlax-curve-getFirstDeriv ent (- par 0.5))
				    (cons pt (mapcar '(lambda (x) (vlax-get ent x))
					      '(StartPoint EndPoint)))))));Line
	  (t (alert "\Wrong Selection!")));cond
    (while pts (setq dpt (last (setq wpt (if pl (car pts) pts)))
		     tpt (polar (caddr wpt) (+ (atan (/ (cadr dpt) (car dpt))) 0.785398) ofs)
		     dpts (mapcar 'vlax-3d-point (subst tpt (caddr wpt) wpt))
		     dim (vla-addDimAligned csp (car dpts) (cadr dpts) (caddr dpts)));setq
      (mapcar '(lambda (x y) (vlax-put-property dim x y))
              '(TextInsideAlign VerticalTextPosition) (list 0 acAbove))
      (setq pts (if pl (cdr pts) nil)));while 
  );vlax-for 
);end
Даёт ошибку в AutoCAD 2010 (Eng, x64)
Код:
[Выделить все]
Command: PlMDim

Select Polylines:
Select objects: Specify opposite corner: 6 found

Select objects:
; error: no function definition: VLAX-GET-ACAD-OBJECT
NemoSUN вне форума  
 
Непрочитано 25.08.2022, 19:46
#22
Кулик Алексей aka kpblc
Moderator

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


(vl-load-com) в самом начале добавь.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 26.08.2022, 15:21
#23
NemoSUN


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


Цитата:
Сообщение от Кулик Алексей aka kpblc Посмотреть сообщение
(vl-load-com) в самом начале добавь.
Добавил.

Теперь если выбираю объект, то:
Command: PlMDim

Select Polylines:
Select objects: 1 found

Select objects:
nil
NemoSUN вне форума  
 
Непрочитано 29.08.2022, 13:54
#24
VVA

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


NemoSUN, Проверил, код рабочий (Автокад 2013). Могу предположить, что у тебя или старые 2d или 3d полилинии. Скопируй в командную строку код
Код:
[Выделить все]
(cdr(assoc 0 (entget(car(entsel)))))
Должен увидеть текст "LWPOLYLINE" Если это не так _CONVERTPOLY в помощь
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 29.08.2022, 15:13
#25
NemoSUN


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


Цитата:
Сообщение от VVA Посмотреть сообщение
NemoSUN, Проверил, код рабочий (Автокад 2013). Могу предположить, что у тебя или старые 2d или 3d полилинии. Скопируй в командную строку код
Код:
[Выделить все]
(cdr(assoc 0 (entget(car(entsel)))))
Должен увидеть текст "LWPOLYLINE" Если это не так _CONVERTPOLY в помощь
Код:
[Выделить все]
(cdr(assoc 0 (entget(car(entsel)))))
проходит.

Приложил пример файла.
Вложения
Тип файла: dwg
DWG 2010
Крыша Бублика-M.dwg (171.3 Кб, 18 просмотров)
NemoSUN вне форума  
 
Непрочитано 29.08.2022, 16:30
#26
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,442


замкнутость
koMon вне форума  
 
Непрочитано 30.08.2022, 16:06
#27
NemoSUN


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


Цитата:
Сообщение от koMon Посмотреть сообщение
замкнутость
О чём это? У меня все контуры замкнуты.
NemoSUN вне форума  
 
Непрочитано 30.08.2022, 16:58
#28
koMon


 
Блог
 
Регистрация: 26.09.2017
Сообщений: 1,442


насколько я понимаю эта программа не проставляет размеры сегментов у замкнутой полилинии, ну по крайней мере у меня не проставляет)

----- добавлено через ~2 мин. -----
Цитата:
Сообщение от NemoSUN Посмотреть сообщение
У меня все контуры замкнуты.
ну вообще-то не все: 48, 49 не замкнуты. но и в них не проставляет так же)
koMon вне форума  
 
Непрочитано 30.08.2022, 18:30
#29
Boxa

КЖ; C#
 
Регистрация: 03.11.2005
Санкт-Петербург
Сообщений: 2,531


Тему посмотрел по диагонали.... и вроде никто про команду "QDIM" ("БРАЗМЕР") еще не писал... NemoSUN, может быть Вам ее будет достаточно?
Boxa вне форума  
 
Непрочитано 01.09.2022, 08:58
#30
VVA

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


Цитата:
Сообщение от koMon Посмотреть сообщение
замкнутость
Оно. Переделал, чтобы по другому определялось количество вершин. Замкнутый сегмент не обрабатывается
Код:
[Выделить все]
(defun C:PlMDim (/ par dim pts dpt wpt tpt dpts lib:pline-get-verts pl:group-by-num vx)
  (vl-load-com)
;;;* Ф-ция lib:pline-get-verts
;;;* Возвращает координаты вершин полилинии
;;;* Взята или на autocad.ru или на dwg.ru 
;;;* Arguments [Type]:
;;;   pline_obj = Object [Vla-Object]
;;;* Возвращает [Type]:
;;;   список координат вида ((90.987 183.524) (93.2774 206.991) (123.052 208.708) (140.23 184.382) (111.6 170.073))
(defun lib:pline-get-verts (pline_obj)
  (if (= (type pline_obj) 'Ename)
    (setq pline_obj (vlax-ename->vla-object pline_obj))
  ) ;_ end of if
      (cond
        ((wcmatch (vlax-get pline_obj 'Objectname )
           "AcDb2dPolyline,AcDb3dPolyline")
         (pl:group-by-num (vlax-get pline_obj 'Coordinates) 3)
        )
        ((eq (vlax-get pline_obj 'Objectname )
           "AcDbPolyline")
         (pl:group-by-num (vlax-get pline_obj 'Coordinates) 2)
        )
       ((eq (vlax-get pline_obj 'Objectname )
           "AcDbLine")
         (list (vlax-curve-getstartpoint pline_obj)(vlax-curve-getendpoint pline_obj))
        )
        (T nil)))
  (defun pl:group-by-num (lst num / ls ret)
(if (= (rem (length lst) num ) 0)
 (progn (setq ls nil)
  (repeat (/ (length lst) num)
    (repeat num (setq ls (cons (car lst) ls) lst (cdr lst)))
  (setq ret (append ret (list (reverse ls))) ls nil)))) ret)

  (prompt "\nSelect Polylines: ") 
  (ssget) 
  (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
        ass (vla-get-ActiveSelectionSet adoc) 
        csp (vla-ObjectIDToObject adoc (vla-get-OwnerID (vla-item ass 0)))
	dvr (mapcar 'getvar '("DIMTXT" "DIMSCALE" "DIMGAP"))
	ofs (+ (* (car dvr) (cadr dvr)) (* (last dvr) 2)))
  (vlax-for ent ass
      (setq vx (lib:pline-get-verts ent))
;;; (if (eq (vla-get-closed ent) :vlax-true)
;;;     (setq vx (append vx (list (car vx)))))
    (setq par (- (length vx) 1))
;;;    (setq par (vlax-curve-getParamAtPoint ent (vlax-curve-getEndPoint ent)))
    (cond ((= (vla-get-objectname ent) "AcDbPolyline") (setq pl t)
	   (while (> par 0) (setq pt (reverse
		(cons (vlax-curve-getFirstDeriv ent (- par 0.5))
		      (reverse (mapcar '(lambda (x) (vlax-curve-getPointAtParam ent x))
				       (list par (1- par) (- par 0.5)))))));setq
	       (if (null pts) (setq pts (list pt)) (setq pts (cons pt pts)));if
	     (setq par (1- par))));PLine
	  ((= (vla-get-objectname ent) "AcDbLine") (setq pl nil)
           (setq pt (vlax-curve-getPointAtParam ent (/ par 2))
		 pts (reverse (cons (vlax-curve-getFirstDeriv ent (- par 0.5))
				    (cons pt (mapcar '(lambda (x) (vlax-get ent x))
					      '(StartPoint EndPoint)))))));Line
	  (t (alert "\Wrong Selection!")));cond
    (while pts (setq dpt (last (setq wpt (if pl (car pts) pts)))
		     tpt (polar (caddr wpt) (+ (atan (/ (cadr dpt) (car dpt))) 0.785398) ofs)
		     dpts (mapcar 'vlax-3d-point (subst tpt (caddr wpt) wpt))
		     dim (vla-addDimAligned csp (car dpts) (cadr dpts) (caddr dpts)));setq
      (mapcar '(lambda (x y) (vlax-put-property dim x y))
              '(TextInsideAlign VerticalTextPosition) (list 0 acAbove))
      (setq pts (if pl (cdr pts) nil)));while 
  );vlax-for 
);end
----- добавлено через ~2 ч. -----
Еще одна версия от marko_ribar

Код:
[Выделить все]
(defun c:pdim ( / ListClockwise-p ch plSet pLlst vLst oldOsn cAng cDis cPt )
;;; Polyline Dimension by marko_ribar  
;;;https://www.cadtutor.net/forum/topic/54351-automatic-distance-between-polygon-vertices/#comment-451128
;;; posted https://forum.dwg.ru/forumdisplay.php?f=13  
 (vl-load-com) 
 (defun ListClockwise-p ( lst / z vlst )
   (vl-catch-all-apply 'minusp 
     (list
       (if 
         (not 
           (equal 0.0
             (setq z
               (apply '+
                 (mapcar 
                   (function
                     (lambda (u v)
                       (- (* (car  u) (cadr  v)) (* (car  v) (cadr  u)))
                     )
                   )
                   (setq vlst
                     (mapcar
                       (function
                         (lambda (a b) (mapcar '- b a))
                       )
                       (mapcar (function (lambda (x) (car lst))) lst) 
                       (cdr (reverse (cons (car lst) (reverse lst))))
                     )
                   )
                   (cdr (reverse (cons (car vlst) (reverse vlst))))
                 )
               )
             ) 1e-6
           )
         )
         z
         (progn
           (prompt "\n\nChecked vectors are colinear - unable to determine clockwise-p of list")
           nil
         )
       )
     )
   )
 )

 (initget 1 "Outside Inside")
 (setq ch (getkword "\nChoose on which side to put dimensions [Outside/Inside] : "))
 (princ "\n<<< Select LwPolyline(s) for dimensioning >>> ")
 (if (setq plSet (ssget '((0 . "LWPOLYLINE"))))
   (progn
     (setq pLlst (vl-remove-if 'listp
                        (mapcar 'cadr(ssnamex plSet)))
           oldOsn (getvar "OSMODE")
     ); end setq
     (setvar "OSMODE" 0) (setvar "CMDECHO" 0)
     (command "_.undo" "_be")
     (foreach pl pLlst
      (setq vLst (mapcar '(lambda( x ) (trans x 0 1)) 
                   (mapcar 'cdr (vl-remove-if-not '(lambda( x ) (= 10 (car x)))
                                  (entget pl)
                                )
                   )
                 )
      ); end setq
      (if (equal (logand (cdr (assoc 70 (entget pl))) 1) 1)
       (setq vLst (append vLst (list (car vLst))))
      ); end if
      (if (not (ListClockwise-p vLst)) (setq vLst (reverse vLst)))
      (while (< 1 (length vLst))
       (setq cAng (angle (car vLst) (cadr vLst))
               cDis (/ (distance (car vLst) (cadr vLst)) 2.0)
       )
;_        (if (>= (caar vLst) (caadr vLst))
;_         (setq cAng (- cAng pi))
;_        ); end if
       (if (eq ch "Inside")
        (setq cPt (polar (polar (car vLst) cAng cDis) (- cAng (* 0.5 pi)) (* 2.5 (getvar "DIMTXT")))); end setq
        (setq cPt (polar (polar (car vLst) cAng cDis) (+ cAng (* 0.5 pi)) (* 2.5 (getvar "DIMTXT")))); end setq
       ); end if
       (command "_.dimaligned" (car vLst) (cadr vLst) cPt)
       (setq vLst (cdr vLst))
      ); end while
     ); end foreach
     (command "_.undo" "_e")
     (setvar "OSMODE" oldOsn) (setvar "CMDECHO" 1)
   ); end progn
 ); end if
 (princ)
)
__________________
Как использовать код на Лиспе читаем здесь
VVA вне форума  
 
Непрочитано 04.09.2022, 17:49
#31
1958


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


Подправлено 5 сентября.
Мой вариант включает также размеры дуговых сегментов:
Код:
[Выделить все]
 ;;; Образмеривание полилинии, автор - 1958
;;; 5 сентября 2022г.
(defun c:dimPl (/ ccol ent poly obj dimObj p1 p2 cPt)
 (vl-load-com)
 (setq ccol (getvar "cecolor"))
 (setvar "cecolor" "5")
 (setq acadObj    (vlax-get-acad-object)
       doc        (vla-get-ActiveDocument acadObj)
       modelSpace (vla-get-ModelSpace doc)
 )
 (setq ent  (car (entsel "\nУкажите полилинию "))
       poly (vlax-invoke (vlax-ename->vla-object ent) 'explode)
 )
 (foreach obj poly
  (coord)
  (cond ((eq (vla-get-Objectname obj) "AcDbLine")
         (setq dimObj (vla-AddDimAligned modelSpace
                                         (vlax-3d-point p1)
                                         (vlax-3d-point p2)
                                         (vlax-3d-point cPt)
                      )
         )
        )
        ((eq (vla-get-Objectname obj) "AcDbArc")
         (setq
          dimObj (vla-AddDimArc modelSpace
                                (vlax-3d-point (vlax-get obj 'Center))
                                (vlax-3d-point p1)
                                (vlax-3d-point p2)
                                (vlax-3d-point cPt)
                 )
         )
        )
  )
  (vla-delete obj)
 )
 (setvar "cecolor" ccol)
 (princ)
)
(defun coord (/ dis pc ang)
 (setq p1  (vlax-get obj 'StartPoint)
       p2  (vlax-get obj 'EndPoint)
       dis (vlax-curve-getDistAtPoint obj p2)
       pc  (vlax-curve-getPointAtDist obj (/ dis 2))
       ang (- (angle '(0. 0. 0.)
                     (vlax-curve-getfirstderiv
                      obj
                      (vlax-curve-getparamatpoint obj (vlax-curve-getclosestpointto obj pc))
                     )
              )
              (/ pi 2)
           )
 )
 (setq cPt (polar pc ang (* 2.0 (getvar "DIMTXT"))))
)

Последний раз редактировалось 1958, 05.09.2022 в 05:30.
1958 вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Можно ли автоматически проставить на полилинии размеры?

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

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