[танбраун]

Добрый день!

Помогите с решением вопроса: нужно вычертить много прямоугольников, разбитых на 2 части (основание и все остальное). Основание будет - отрезок зеленого цвета, п-образная часть - полилиния синяя. Решить наверное можно с помощью лиспа, но к сожалению ноль в этом вопросе. AutoCad 2019. За ранее благодарен.

[Кулик Алексей aka kpblc]

Либо _.dataextraction, либо вопрос в другом разделе.

[koMon]

Сообщение от танбраун Решить наверное можно с помощью лиспа

наверняка...с упрощённым группообразованием

Код:

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

 
;*************************************************************************************************************************

(vl-load-com)

;*************************************************************************************************************************

(defun draw_rect (parsed_point_3 parsed_point_1 parsed_modelspace_object parsed_rect_exists /
				  point_1 point_2 point_3 point_4 p1_p3_distance pline_coordinates_array line_object_dxf pline_object_dxf)

    (setq point_1 (list (car parsed_point_1) (cadr parsed_point_1))
		  point_2 (list (car parsed_point_1) (cadr parsed_point_3))
		  point_3 (list (car parsed_point_3) (cadr parsed_point_3))
		  point_4 (list (car parsed_point_3) (cadr parsed_point_1))
		  p1_p3_distance (distance parsed_point_1 parsed_point_3)
		  pline_coordinates_array (vlax-make-safearray vlax-vbDouble '(0 . 7))
	)
	(vlax-safearray-fill pline_coordinates_array (append point_1 point_2 point_3 point_4))
	(if (null parsed_rect_exists)
		(if (null (zerop p1_p3_distance))
			(progn
    			(setq line_object (vla-addline parsed_modelSpace_object (vlax-3d-point point_1) (vlax-3d-point point_4))
					  pline_object (vla-addlightweightpolyline parsed_modelSpace_object pline_coordinates_array)
					  rect_exists t
					  line_object_dxf (entget (vlax-vla-object->ename line_object))
					  pline_object_dxf (entget (vlax-vla-object->ename pline_object))
				)
				(if (assoc 420 line_object_dxf)
					(setq line_object_dxf (vl-remove (assoc 420 line_object_dxf) line_object_dxf))
				)
				(if (null (assoc 62 line_object_dxf))
					(setq line_object_dxf (append line_object_dxf (list (cons 62 3))))
					(setq line_object_dxf (subst (cons 62 3) (assoc 62 line_object_dxf) line_object_dxf))
				)
				(if (assoc 420 pline_object_dxf)
					(setq pline_object_dxf (vl-remove (assoc 420 pline_object_dxf) pline_object_dxf))
				)
				(if (null (assoc 62 pline_object_dxf))
					(setq pline_object_dxf (append pline_object_dxf (list (cons 62 5))))
					(setq pline_object_dxf (subst (cons 62 5) (assoc 62 pline_object_dxf) pline_object_dxf))
				)
				(entmod line_object_dxf)
				(entmod pline_object_dxf)
			)
		)
		(if (null (zerop p1_p3_distance))
			(progn
				(vla-put-endpoint line_object (vlax-3d-point point_4))
    			(vla-put-coordinates pline_object pline_coordinates_array)
			)
		)
	)
)


;*************************************************************************************************************************

(defun c:2_Color_Rect (/ modelSpace_object point_1 getting_point_3 rect_exists groups_collection group_sset group_index error_ocurred gread_data)
	(setq modelSpace_object (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
		  point_1 (getpoint "\nПервая точка диагонали прямоугольника: ")
		  getting_point_3 t
		  rect_exists nil
		  groups_collection (vla-get-groups (vla-get-ActiveDocument (vlax-get-acad-object)))
		  group_sset (ssadd)
		  group_index (getvar 'useri1)
	)
	(while getting_point_3
		(setq error_ocurred (if (vl-catch-all-error-p (setq gread_data (vl-catch-all-apply 'grread (list t 8 0)))) t nil))
    	(cond
			(
				error_ocurred
					(prompt "\nНеверно!")
			)
			(
			   	(= 25 (car gread_data))				;Mouse Right Click
					(setq point_3 (getpoint point_1 "\nВторая точка диагонали прямоугольника: ")
						  getting_point_3 nil
					)
					(draw_rect point_3 point_1 modelspace_object rect_exists)
			)
			(
			   	(= 5 (car gread_data))				;Mouse Moving
					(draw_rect (cadr gread_data) point_1 modelspace_object rect_exists)
			)
			(
				(or
					(equal gread_data (quote (2 32)))		;Space
					(equal gread_data (quote (2 13)))     	;Enter
					(= 3 (car gread_data))				    ;Mouse Left Click
				)
					(setq getting_point_3 nil)

			)
			(
			 	t
					(prompt "\nНеверно!")
			)
		)
	)
	(ssadd (vlax-vla-object->ename line_object) group_sset)
	(ssadd (vlax-vla-object->ename pline_object) group_sset)
	(while (null (vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list groups_collection (setq group_name (strcat "Rect_" (itoa (setq group_index (1+ group_index))))))))))
	(setvar 'useri1 group_index)
	(command "_-group" "_c" group_name "2_Color_Rect" group_sset "")
	(vlax-release-object line_object)
	(vlax-release-object pline_object)
	(princ)
)

;*************************************************************************************************************************