;;;
;;;round_point
;;;
(defun round_point (point val)
(list
(* (fix (/ (car point) val)) val)
(* (fix (/ (cadr point) val)) val)
)
)
;;;
;;; groop_list
;;;
(defun groop_list (list_ i / first temp_list final_list)
(setq list_ (mapcar (function (lambda (x)
(list
(round_point (car x) i)
(car x)
(cadr x)
)
)
)
list_
)
)
(while list_
(setq first (caar list_)
temp_list (list(cdar list_))
list_ (cdr list_)
)
(while (setq temp (assoc first list_))
(setq temp_list (cons (cdr temp) temp_list)
list_ (vl-remove temp list_)
)
)
(setq final_list
(cons
(cons first (list temp_list))
final_list
)
)
)
final_list
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(if (setq
nabor
(ssget
"_:A"
(list
(cons 0 "POINT,TEXT")
)
)
)
(progn
(setq nabor (mapcar 'vlax-ename->vla-object
(vl-remove-if
'listp
(mapcar 'cadr
(ssnamex nabor)
)
)
)
)
(foreach item nabor
(if (= (vla-get-objectname item) "AcDbText")
(setq text_list
(cons
(list
(3D->2D
(vlax-safearray->list
(vlax-variant-value
(vla-get-InsertionPoint item)
)
)
)
item
)
text_list
)
)
(setq point_list
(cons
(list
(3D->2D
(vlax-safearray->list
(vlax-variant-value
(vla-get-coordinates item)
)
)
)
item
)
point_list
)
)
)
)
;Группируем объекты Текст в дерево
(setq i 10)
(while (> (length (setq text_list (groop_list text_list i))) 2)
(setq i (* 10 i))
)
; Проходимся по списку Точек
(foreach item point_list
(setq koord (car item)
koord (list (+ (car koord) d_x) (+ (cadr koord) d_y))
; Находим 4 угла, в радиусе допуска вокруг искомой точки
koord_list (mapcar
(function (lambda (x)
(round_point(mapcar '+ koord x)10)
)
)
'((0.1 -0.1) (0.1 0.1) (-0.1 0.1) (-0.1 -0.1))
)
;Проверяем не попадают ли эти 4 вершины в один "листочик" на дереве (удаляем дубли)
koord_list (reverse
(cons
(car koord_list)
(vl-remove (car koord_list) (cdr koord_list))
)
)
koord_list (cons (car koord_list)
(vl-remove (car koord_list) (cdr koord_list))
)
)
;Пройдёсь по дереву, из большого списка Текстов выбираем нужные нам листочки
(setq smol_text_list
(apply 'append
(mapcar (function (lambda (x)
(setq j i
temp_text_list text_list)
(while (>= j 10)
(setq temp_text_list
(cadr (assoc
(round_point
x
j
)
temp_text_list
)
)
j (/ j 10)
)
)
temp_text_list
)
)
koord_list
)
)
)
; И уже маленький список Текстов проверяем на equal'ом
(if (setq text
(car
(vl-remove-if-not
(function
(lambda (x)
(equal (car x) koord 0.1)
)
)
smol_text_list
)
)
)
(progn
(setq par_list
(cons
(list
koord
(cadr item)
(cadr text)
)
par_list
)
)