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

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

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

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

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

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


Можно. Примерно так:
Код:
[Выделить все]
(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,148


Тогда непонятна сама проблема, потому как при построении любого размера, что прямого, что выраненного (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,148


Цитата:
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
Ростов-на-Дону
Сообщений: 4,932


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

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


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

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


А у нас обед (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
Ростов-на-Дону
Сообщений: 4,932


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

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


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
Ростов-на-Дону
Сообщений: 4,932


>Лентяй
>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
Ростов-на-Дону
Сообщений: 4,932


Мне не жалко :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
С.-Петербург
Сообщений: 36,686


dwg.ru/art/8
__________________

---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей 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 вне форума  
Ответ
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Можно ли автоматически проставить на полилинии размеры?

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

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