[doki]

Идея такая: есть раскладка прямоугольников (сплайны), они розложены со швом 6 мм.... хочу такую функцию: если рядом 4 точки (пересечение швов четырех прямоугольников), то вставляется на это место блок "1", если рядом только две вершины по вертикали, то ставится блок "2", если рядом две вершины по горизонтали то "3"... у кого-то есть предложения?

[VVA]

Как-то так. Только не сплайны, а LW полилинии

Код:

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

(defun mip-text-entmake (txt pnt height rotation justification / ent_list)
  (setq  ent_list (list  '(0 . "TEXT")
     '(100 . "AcDbEntity")
     '(100 . "AcDbText")
     (list 10 (car pnt) (cadr pnt) 0.0)
     (cons 1 txt)
     (cons 40 height)
     (if justification
       (cond
         ((= justification "C")  '(72 . 1))
         ((= justification "R")  '(72 . 2))
         ((= justification "A")  '(72 . 3))
         ((= justification "M")  '(72 . 4))
         ((= justification "F")  '(72 . 5))
         (t '(72 . 0))
       ) ;_ end of cond
       '(72 . 0)
     ) ;_ end of if
     (cons 50 rotation)
     (list 11 (car pnt) (cadr pnt) 0.0)
     ) ;_ end of list
   ) ;_ end of setq
   (entmakex ent_list)
)
(defun mip_MakeUniqueMembersOfList  ( lst / OutList head)
  (while lst
    (setq head (car lst)
          lst (vl-remove-if '(lambda(pt)(equal pt head 1e-6)) lst)
          OutList (append OutList (list head))))
  OutList
  )
(defun C:TEST ()
(if 
(and
  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  (setq i '-1)
  (repeat (sslength ss)
    (setq e1 (ssname ss (setq i (1+ i))))
    (setq coors (vl-remove-if-not '(lambda(x)(= (car x) 10))(entget e1)))
    (setq coors (mapcar 'cdr coors))
    (setq lst (append coors lst))
  ) ;_ end of repeat
  (setq lst (mip_MakeUniqueMembersOfList  lst))
  )
(progn
  (foreach pt lst
    (setq pt1 (mapcar '+ pt '(1 1)))
    (setq pt2 (mapcar '- pt '(1 1)))
    (setq ss1 nil ss1 (ssget "_C" pt1 pt2 '((0 . "LWPOLYLINE"))))
    (if ss1
      (progn
        (setq col (sslength ss1))
        (if (= col 4)(setq col 1))
        (mip-text-entmake (itoa col) pt 2 0 "M")
      )
    )
    )
  (setq ss1 nil)
  )
)
  (princ)
  )

[doki]

почти оно.... только результат не тот

[VVA]

А так

Код:

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

;http://dwg.ru/f/showthread.php?t=16675
(defun mip-text-entmake (txt pnt height rotation justification / ent_list)
  (setq  ent_list (list  '(0 . "TEXT")
     '(100 . "AcDbEntity")
     '(100 . "AcDbText")
     (list 10 (car pnt) (cadr pnt) 0.0)
     (cons 1 txt)
     (cons 40 height)
     (cons 7 (getvar "TEXTSTYLE"))
     (if justification
       (cond
         ((= justification "C")  '(72 . 1))
         ((= justification "R")  '(72 . 2))
         ((= justification "A")  '(72 . 3))
         ((= justification "M")  '(72 . 4))
         ((= justification "F")  '(72 . 5))
         (t '(72 . 0))
       ) ;_ end of cond
       '(72 . 0)
     ) ;_ end of if
     (cons 50 rotation)
     (list 11 (car pnt) (cadr pnt) 0.0)
     ) ;_ end of list
   ) ;_ end of setq
   (entmakex ent_list)
)
(defun C:TEST ( / ss i coors lst _loc_MakeUniqueMembersOfListWithCount ret res val pt pt1 pt2)
  (defun _loc_MakeUniqueMembersOfListWithCount  ( lst / OutList head countelt)
  (while lst
    (setq head (car lst)
   countelt 0
          lst (vl-remove-if '(lambda(pt)(if (equal pt head 1)(setq countelt (1+ countelt)) nil)) lst)
          OutList (append OutList (list (cons head countelt)))))
  OutList
  )
(vl-load-com)
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object))) 
(if 
(and
  (setq ss (ssget '((0 . "LWPOLYLINE"))))
  (setq i '-1)
  (repeat (sslength ss)
    (setq e1 (ssname ss (setq i (1+ i))))
    (setq coors (vl-remove-if-not '(lambda(x)(= (car x) 10))(entget e1)))
    (setq coors (mapcar 'cdr coors))
    (setq lst (append coors lst))
  ) ;_ end of repeat
  )
(progn
  (setq ret nil)
  (foreach itm lst
    (if (not(apply 'or (mapcar '(lambda(x)(vl-some '(lambda(y)(equal itm y 1e-3)) x)) ret)))
      (progn
        (setq res (vl-remove-if-not '(lambda(x)(equal x itm 10)) lst))
        (setq ret (cons res ret))
        )
      )
    )
  (foreach itm ret
    (cond
      ((= (length itm) 4)
       (setq pt (polar (setq pt1 (apply 'mapcar (cons 'min itm)))
                       (angle pt1
                              (setq pt2 (apply 'mapcar (cons 'max itm)))
                              )
                       (* 0.5 (distance pt1 pt2))
                       )
             val (list(cons pt 1))
             )
       )
      ((member (length itm) '(2 3))
       (setq val nil)
       (setq lstXY (apply 'mapcar (cons 'list itm)))
       (if (setq res(vl-remove-if-not '(lambda(x)(= (cdr x) 2))(_loc_MakeUniqueMembersOfListWithCount (car lstXY))))
         (setq val (append val
                           (list
                             (cons (list (caar res)(caadr lstXY))
                                   2)
                             )
                           )
               )
         )
       (if (setq res(vl-remove-if-not '(lambda(x)(= (cdr x) 2))(_loc_MakeUniqueMembersOfListWithCount (cadr lstXY))))
         (setq val (append val
                           (list
                             (cons (list (caar lstXY)(caar res))
                                   3)
                             )
                           )
               )
         )
       )
      ((=(length itm) 1)
       (setq  val (list(cons (car itm) 3)))
       )
      (t (setq val nil))
      )
      (foreach xx val
        (mip-text-entmake (itoa (cdr xx)) (car xx) 200 0 "M")
        )
    )
)
)
(vla-EndUndoMark (vla-get-activedocument (vlax-get-acad-object)))  
  (princ)
  )

[doki]

так вообще супер.... только углы пропускает.... "3" должны быть

[VVA]

Это к вопросу о полном ТЗ. В посте 1 по угол (1 точка) ничего не сказано.
Исправил код #4

[doki]

тогда я упустил.... забираю свои слова обратно

[doki]

VVA... один ты мне помогаешь.... так как на счет вставки "3" по угловым еденичным точкам?... такое осилишь?

[VVA]

Почитай внимательнее пост #6

Исправил код #4

Сделал это еще 18

[doki]

Спасибо огромное... сразу тебя не понял