Alıntı

---

macros55 :

---

Alıntı

---

alumina :

Alıntı

---

macros55 :

---

"Enter the layer name:" iletisinde layer adi girilirse create edilen pointler ve islem yapilan textler girilen layer adinda olur, enterle veya sag tus ile pas gecilirse aktif layerde olur..

Kod:

(defun c:qw (/ dc ss ln lm e k s0 ts t0 tn tp ld ls)
            (vl-load-com)
  (if (and (setq dc (vla-get-ActiveDocument
               (vlax-get-acad-object))
          ss (ssget '((0 . "LwPolyline") (8 . "hat"))))
        (setq ln (getstring T "\nEnter the layer name:")))
    (progn (vla-StartUndomark dc)
      (repeat (setq k (sslength ss))
        (setq k (1- k)
          s0 (ssname ss k)
            ts (ssget "_X" '((0 . "*Text") (8 . "Kot")))
              ls nil)
        (repeat (setq e (sslength ts))
          (setq e (1- e)
            t0 (ssname ts e)
              tn (entget t0)
                tp (cdr (assoc 10 tn))
            ls (cons (list (distance tp
                 (vlax-curve-getClosestPointTo
                   (vlax-ename->vla-object s0) tp T)) tp
                 (atof (getpropertyvalue t0
                   (if (= (cdr (assoc 0 tn)) "MTEXT")
                     "Text" "TextString"))) t0) ls))
         )
         (setq ld (car (vl-sort ls '(lambda(a b)
             (< (car a) (car b)))))
           lm (if (= ln "") (getvar "Clayer") ln)
             tm (entget (nth 3 ld)))
         (entmake (list '(0 . "Point") (cons 8 lm)
           (cons 10 (append (cadar (vl-sort (mapcar '(lambda(a)
              (list (distance (cadr ld) a) a))
                (mapcar 'cdr (vl-remove-if '(lambda(x)
                  (/= (car x) 10)) (entget s0))))
              '(lambda(a b) (> (car a) (car b)))))
                 (list (caddr ld))))))
         (entmod (subst (cons 8 lm) (assoc 8 tm) tm))
      ) (vla-EndUndomark dc)
    )
  ) (prin1)
)

---