[编程交流] 尺寸断开连接

(vl-load-com)
(defun c:test (/ n x ent entL p2 p3 px1 px2 py1 py2 ptdd xl sa pt0 ppt ptdd)
(setvar "cmdecho" 0)
(command "undo" "be")
(setq entL '())
(if (setq ent (centsel "\nChoose Dimension or <EXIT>:" "DIMENSION"))
  (progn
    (setq x (entget ent)
       entL (cons ent entL)
         p2 (dxf 13 x)
         p3 (dxf 14 x)
         px1 (list (car p2) (/ (+ (cadr p2)(cadr p3)) 2.0))
         px2 (list (car p3) (/ (+ (cadr p2)(cadr p3)) 2.0))
         py1 (list (/ (+ (car p2)(car p3)) 2.0) (cadr p2))
         py2 (list (/ (+ (car p2)(car p3)) 2.0) (cadr p3))
         ptdd (list p2 p3)
         XL (entget (dxf -2 (tblsearch "block" (dxf 2 x))))
         SA (abs (sin (angle (dxf 10 xl) (dxf 11 xl)))))
  (while (setq pt0 (getpoint "\nPick point or <EXIT>:"))
      (command ".copy" ent "" "0,0" "@")
      (setq entL (cons (entlast) entL))
   (cond
     ((equal SA 1 1e-6) ;;horizonta
        (setq ptdd (cons (ptper pt0 px1 px2) ptdd)
                ppt (Lsort ptdd 0))
       )
     ((equal SA 0 1e-6) ;;vertical 
        (setq ptdd (cons (ptper pt0 py1 py2) ptdd)
               ppt (Lsort ptdd 1))
      )
      (t (setq ptdd (cons (ptper pt0 p2 p3) ptdd)
           ppt (Lsort ptdd 2)))
     )
      (setq ppL (mapcar 'list ppt (cdr ppt))
             n 0)
        (repeat (length ppL)
          (setq xf (entget (nth n entL))
               nxf (subst (cons 13 (car  (nth n ppL)))(assoc 13 xf) xf)
               wxf (subst (cons 14 (cadr (nth n ppL)))(assoc 14 nxf) nxf)
               n (1+ n))
          (entmod wxf)
        )
    ))
 (princ "\nEXIT")
)
 (command "undo" "e") (setvar "cmdecho" 1)
 (princ)
)
(defun centsel (msg f)
(while (if (setq el (car (entsel msg))) (if (= (cdr (assoc 0 (entget el))) f) nil t) nil)) el
)
;;dxf
(defun dxf (x e)(cdr (assoc x e)))
;;pedal
(defun ptper (pt0 pt1 pt2)
(inters pt0 (polar pt0 (+ (angle pt1 pt2) (/ pi 2)) 1.0) pt1 pt2 nil)
)
;;sorting  0 horizonta 1 vertical 2 Oblique
(defun Lsort (LT i)
(cond
((or (= i 0)(= i 2))(setq Lt (vl-sort LT (function (lambda (e1 e2)(< (car e1) (car e2)))))))
((or (= i 1)(= i 2))(setq Lt (vl-sort LT (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))))))
))
(princ)

 (cond
  ((equal SA 1 1e-6)
   ;;horizonta
   (setq ptdd (cons pt0 ptdd) 
         ppt  (Lsort ptdd 0)
   )
  )
  ((equal SA 0 1e-6)
   ;;vertical 
   (setq ptdd (cons pt0 ptdd) 
         ppt  (Lsort ptdd 1)
   )
  )
  (t
   (setq ptdd (cons pt0 ptdd) 
         ppt  (Lsort ptdd 2)
   )
  )
)

(setq ppL (mapcar 'list ppt (cdr ppt))              
      n          0
      tt10 (cdr (assoc 10 (entget (nth n entL))))
)
(repeat        (length ppL)
  (setq        xf  (entget (nth n entL))
        nxf (subst (cons 13 (car (nth n ppL))) (assoc 13 xf) xf)
        wxf (subst (cons 14 (cadr (nth n ppL))) (assoc 14 nxf) nxf)
        wxf (subst (cons 10 tt10) (assoc 10 wxf) wxf)
        n   (1+ n)
  )
  (entmod wxf)
)

(defun c:test( / ss ic xic aa bb n ent1)
(setvar "cmdecho" 0)
(command "undo" "be")
(princ "\nPlease choose dimension for merge ")
(setq ss (ssget '((0 . "DIMENSION")))
     sumn (sslength ss) n 0 xss '() aa '())
(repeat sumn (setq xss (cons (ssname ss n) xss) n (1+ n)))
(while (car xss)
 (setq bb '()
       bb (cons (car xss) bb)
       ic (getxx (entget (car xss)))
       xss (cdr xss) 
       yss xss)
 (while (car yss)
   (setq ent1 (car yss)
          xic (getxx (entget ent1)))
    (if (apply 'and (mapcar '(lambda(x y)(equal x y 1e-5)) xic ic))
        (setq bb (cons ent1 bb)
             xss (vl-remove ent1 xss)))
        (setq yss (cdr yss)))
  (setq aa (cons bb aa))
)
(setq n 0)
(repeat (length aa)
 (setq ent1 (nth n aa) n (1+ n))
 (if (cdr ent1)(progn
   (setq ptx (getmxy ent1)
         xf (entget (car ent1))
        nxf (subst (cons 13 (car  ptx))(assoc 13 xf) xf)
        wxf (subst (cons 14 (cadr ptx))(assoc 14 nxf) nxf)
         xx (cdr ent1))
   (entmod wxf)
   (while xx (entdel (car xx)) (setq xx (cdr xx)))
 ))
)
(command "undo" "e") (setvar "cmdecho" 1)
(princ)
)
(defun dxf (x e)(cdr (assoc x e)))
(defun getxx(x / xy xl a b bb)
(setq xy (dxf 10 x)
     xl (entget (dxf -2 (tblsearch "block" (dxf 2 x))))
      A (angle (dxf 10 xl) (dxf 11 xl)))
(cond
  ((equal (abs (sin A)) 1 1e-6) ;;horizonta
     (list (cadr xy) (sin A)))
  ((equal (sin A) 0 1e-6) ;;vertical 
     (list (car xy) (sin A)))
  (t (setq B (+ A (* 0.5 pi))
          bb (- (cadr xy) (* (/ (sin B)(cos B)) (car xy))))
     (list bb (sin A)))
 )
)
(defun getmxy(ssent / ptx xx yy A xl sa)
(foreach x ssent
   (setq ptx (cons (dxf 13 (entget x)) ptx)
         ptx (cons (dxf 14 (entget x)) ptx)))
(setq xl (entget (dxf -2 (tblsearch "block" (dxf 2 (entget (car ssent))))))
      A (angle (dxf 10 xl) (dxf 11 xl)))
(cond
     ((equal SA 1 1e-6) (setq ppt (Lsort ptx 0)))
     ((equal SA 0 1e-6) (setq ppt (Lsort ptx 1)))
      (t (setq ppt (Lsort ptx 2)))
 )(list (car ppt)(last ppt))
)
(defun Lsort (LT i)
(cond
((or (= i 0)(= i 2))(setq Lt (vl-sort LT (function (lambda (e1 e2)(< (car e1) (car e2)))))))
((or (= i 1)(= i 2))(setq Lt (vl-sort LT (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))))))
))
(princ)