Автоматическое создание атрибутов блоков в автокад. LISP.

По просьбе подписчика с моего канала на YouTube выкладываю скрипт на языке LISP для создания атрибутов блоков, из поста Демонстрация работы связки AutoCad и MS SQL для создания смет, спецификаций и др.. Для товарищей, которые считают себя гуру LISP : не нравится – не используйте. Я не претендую на звание супер-разработчика. У меня работает и мне этого достаточно. Собственно лисп:


  1. (defun begin_activex ( / ) 
  2.   (vl-load-com) 
  3.   (setq acad_application (vlax-get-acad-object)) 
  4.   (setq active_document (vla-get-ActiveDocument acad_application)) 
  5.   (setq model_space (vla-get-ModelSpace active_document)) 
  6.   (setq paper_space (vla-get-PaperSpace active_document)) 
  7. )
  8. (begin_activex)
  9. (defun c:attsCreate   ( / )
  10. 	(defun-q  createLayer (layerName layerColor / )
  11. 		(entmakex
  12. 			(list
  13. 				(cons 0 "LAYER")
  14. 				(cons 100 "AcDbSymbolTableRecord")
  15. 				(cons 100 "AcDbLayerTableRecord")
  16. 				(cons 2  layerName)
  17. 				(cons 70 0) 
  18. 				(cons 62 layerColor)
  19. 			)		
  20. 		)
  21. 		;------Return---------
  22. 		;
  23. 		;
  24. 		;---Call parametrs----
  25. 		;
  26. 		;
  27. 		;
  28. 		;
  29.  
  30. 	)
  31. 	; Call example:
  32. 	;
  33. 	(setq
  34. 		defaultAttTag
  35. 		(list
  36. 			"ID"
  37. 			"SQLID"
  38. 			"FULLNAME"
  39. 			"SHORTNAME"
  40. 			"GROUPNAME"
  41. 			"IDENTIFIER"
  42. 			"FACTORYMANUFACTURER"
  43. 			"DESCRIPTION"
  44. 			"POSITION"
  45. 			"NOTES"
  46. 			"MU"
  47. 			"PRICE"
  48. 			"PRICEID"
  49. 		)	
  50. 		cableTag
  51. 		(list
  52. 			"CABLENUM"
  53. 			"CABLETYPE"
  54. 			"CABLELENGTH"
  55. 			"CABLEPURPOSE"
  56. 			"CABLESTART"
  57. 			"CABLEEND"
  58. 		)
  59. 		p_adressTag "PARENTADRESS"
  60. 		s_adressTag "SELFADRESS"
  61.  
  62. 	)
  63.  
  64.  
  65.  
  66. 	(setq 
  67. 		vlaBlock (vlax-ename->vla-object (car (entsel "\nУкажите блок: ")))
  68. 		adressQuantity (getint  "Укажите количество дочерних адресов:")
  69. 		wiresQuantity (getint  "Укажите количество проводов:")
  70. 		textHeigth (getreal  "Укажите высоту текста:")
  71. 	)
  72. 	(setq vlaBlockReal (vla-item (vla-get-blocks active_document) (vla-get-EffectiveName vlaBlock))) ; Получаем указатель на описание блока
  73. 	(setq userLayer (getvar "CLAYER")) ; запоминаем текущий слой
  74. 	(setvar  "CLAYER" "0") ; устанавливем слой 0 для вставки обязательных атрибутов 
  75. 	(setq
  76. 		slideDown 1 ; счетчик для смещения атрибутов
  77. 	)
  78. 	; Добавление обязательных атрибутов<<<<<<<<<<<<<<<<<<<<
  79. 	(foreach AttTag defaultAttTag 
  80. 		(vla-AddAttribute
  81. 			vlaBlockReal ; объект для вставки атрибута
  82. 			textHeigth ; высота текста
  83. 			acAttributeModeInvisible ; acAttributeModeInvisible ; тип атрибута
  84. 			""  ; Подсказка при вводе
  85. 			(vlax-3D-point ; координата точки вставки
  86. 				(list
  87. 					0.0
  88. 					(* -1 (+ textHeigth (* 0.5 textHeigth)) slideDown)
  89. 					0.0
  90. 				)
  91. 			)
  92. 			AttTag ; Имя атрибута
  93. 			""  ; Значение атрибута
  94. 		)
  95. 		(setq slideDown (1+ slideDown))
  96. 	) 
  97. 	; Добавление обязательных атрибутов>>>>>>>>>>>>>>>>>>>>>
  98. 	; Добавление атрибутов адресов<<<<<<<<<<<<<<<<<<<<<<<<<
  99. 	(if (null (tblsearch "LAYER" (strcat "att." p_adressTag)))
  100. 		(progn ;true
  101. 			(createLayer (strcat "att." p_adressTag) 1)
  102. 		)
  103.  
  104. 	);(null (tblsearch "LAYER" "att.PARENTADRESS"))
  105. 	(setvar  "CLAYER" (strcat "att." p_adressTag))
  106. 	(setq ; задаем точку вставки и точку выравнивания
  107. 		insertionPoint 
  108. 		(vlax-3D-point ; координата точки вставки
  109. 			(list
  110. 				(* -1.0 textHeigth)
  111. 				0.0
  112. 				0.0
  113. 			)
  114. 		)
  115. 	)
  116. 	(setq 
  117. 		att 
  118. 		(vla-AddAttribute
  119. 			vlaBlockReal ; объект для вставки атрибута
  120. 			textHeigth ; высота текста
  121. 			acAttributeModeNormal ; acAttributeModeInvisible ; тип атрибута
  122. 			""  ; Подсказка при вводе
  123. 			insertionPoint
  124. 			p_adressTag ; Имя атрибута
  125. 			""  ; Значение атрибута
  126. 		);(vla-AddAttribute
  127. 	)
  128. 	(vla-put-Alignment att acAlignmentRight)
  129. 	(vla-put-TextAlignmentPoint att insertionPoint)
  130.  
  131. 	(setq adressNumber 1)
  132. 	(repeat (1- (1+ adressQuantity))
  133. 		(if (null (tblsearch "LAYER" (strcat "att.SELFADRESS" (itoa adressNumber))))
  134. 			(progn ;true
  135. 				(createLayer (strcat "att.SELFADRESS" (itoa adressNumber)) 5)
  136. 			)
  137.  
  138. 		);(null (tblsearch "LAYER" "att.PARENTADRESS"))
  139. 		(setvar  "CLAYER" (strcat "att.SELFADRESS" (itoa adressNumber)))
  140. 		(setq ; задаем точку вставки и точку выравнивания
  141. 			insertionPoint 
  142. 			(vlax-3D-point ; координата точки вставки
  143. 				(list
  144. 					(* -1 textHeigth)
  145. 					(* (+ textHeigth (* 0.5 textHeigth)) adressNumber )
  146. 					0.0
  147. 				)
  148. 			)
  149. 		)
  150. 		(setq 
  151. 			att 
  152. 			(vla-AddAttribute
  153. 				vlaBlockReal ; объект для вставки атрибута
  154. 				textHeigth ; высота текста
  155. 				acAttributeModeNormal ; acAttributeModeInvisible ; тип атрибута
  156. 				""  ; Подсказка при вводе
  157. 				insertionPoint
  158. 				(strcat "SELFADRESS" (itoa adressNumber)) ; Имя атрибута
  159. 				""  ; Значение атрибута
  160. 			);(vla-AddAttribute
  161. 		)
  162. 		(vla-put-Alignment att acAlignmentRight)
  163. 		(vla-put-TextAlignmentPoint att insertionPoint)
  164. 		;счетчик--------------------------------------
  165. 		(setq adressNumber (1+ adressNumber));--------
  166. 		;---------------------------------------------
  167. 	)
  168.  
  169. 	; Добавление атрибутов адресов>>>>>>>>>>>>>>>>>>>>>>>>>
  170.  
  171. 	; Добавление атрибутов проводов<<<<<<<<<<<<<<<<<<<<<<<<<
  172.  
  173. 	(if (< 0 wiresQuantity)
  174. 		(progn ;true
  175. 			(setvar  "CLAYER" "0") ; устанавливем слой 0 для вставки  атрибутов проводов
  176. 			(setq cableNum 1) ; начальный счетчик проводов
  177. 			(repeat (1- (1+ wiresQuantity))
  178. 				(foreach AttTag cableTag
  179. 					(vla-AddAttribute
  180. 						vlaBlockReal ; объект для вставки атрибута
  181. 						textHeigth ; высота текста
  182. 						acAttributeModeInvisible ; acAttributeModeInvisible ; тип атрибута
  183. 						""  ; Подсказка при вводе
  184. 						(vlax-3D-point ; координата точки вставки
  185. 							(list
  186. 								0.0
  187. 								(* -1 (+ textHeigth (* 0.5 textHeigth)) slideDown)
  188. 								0.0
  189. 							)
  190. 						)
  191. 						(strcat (itoa cableNum) AttTag) ; Имя атрибута
  192. 						""  ; Значение атрибута
  193. 					);(vla-AddAttribute
  194. 				);(foreach AttTag cableTag
  195. 				(setq slideDown (1+ slideDown))
  196. 				(setq cableNum (1+ cableNum))
  197. 			);(repeat (1- wiresQuantity)
  198. 		)
  199. 		(progn ;false
  200.  
  201. 		)
  202. 	);if (< 0 wiresQuantity)
  203.  
  204. 	; Добавление атрибутов проводов>>>>>>>>>>>>>>>>>>>>>>>>>
  205.  
  206.  
  207. 	(setvar  "CLAYER" userLayer) ; возвращаем слой
  208.  
  209.  
  210.  
  211. 	 (if (not (member "battman.arx" (arx)))
  212. 	(arxload "battman.arx")
  213. 	) ;_ end of if
  214. 	(acet-attsync (vla-get-name vlaBlockReal )) ;vlaBlock
  215. )

Небольшой комментарий. Команда attsCreate выведена на кнопку в рабочем пространстве, для удобства. Атрибуты со значениями адресов – видимые и создаются в своих слоях для возможности их отключения.
Пример работы:

Оцените пожалуйста статью:

ПечальноТак себеНе плохоХорошоОтличная статья! 1 оценок.
Загрузка...

3 Replies to “Автоматическое создание атрибутов блоков в автокад. LISP.

  1. Очень интересно, но после ввода высоты текста выдает “ошибка: неверный тип аргумента: VLA-OBJECT nil”

    1. Михаил, вероятно у вас не подгружен activeX. Просто у меня он подгружается автоматически и, видимо, это я упустил. Я подправил код. Проверьте пожалуйста. Спасибо за наводку.

Добавить комментарий

Ваш e-mail не будет опубликован. Обязательные поля помечены *