;;;Marko Ribar Program from topic: http://www.theswamp.org/index.php?topic=50682.0

(defun c:ad ( / overlaplinedisp mk_txt imgtxtblk2bb ucsf ss *size* i e k ep a seglen midsegpt len midpt txth bbh li lil handlst bblst )

(vl-load-com)

(defun overlaplinesdisp ( lil / SetEntityTransparency unique unit chkoverlap collinear-p olig oligs trf n )

(defun SetEntityTransparency ( entity transparency )
(entmod
(append
(entget entity)
(list (cons 440 (+ (lsh 2 24) (fix (- 255 (* transparency 2.55))))))
)
)
)

(defun unique ( l )
(if l (cons (car l) (vl-remove-if '(lambda ( x ) (vl-every '(lambda ( y ) (vl-position y (car l))) x)) (unique (cdr l)))))
)

(defun unit ( v )
(mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
)

(defun chkoverlap ( li1 li2 / p1 p2 p3 p4 )
(setq p1 (cdr (assoc 10 (entget li1))) p2 (cdr (assoc 11 (entget li1))) p3 (cdr (assoc 10 (entget li2))) p4 (cdr (assoc 11 (entget li2))))
(if (and (ssmemb li2 (ssget "_F" (list p1 p2))) (or (equal (unit (mapcar '- p2 p1)) (unit (mapcar '- p4 p3)) 1e-6) (equal (unit (mapcar '- p2 p1)) (unit (mapcar '- p3 p4)) 1e-6)))
t
nil
)
)

(defun collinear-p ( p1 p p2 )
(equal (distance p1 p2) (+ (distance p1 p) (distance p p2)) 1e-6)
)

(foreach li1 lil
(setq olig (cons li1 olig))
(foreach li2 (vl-remove li1 lil)
(if (chkoverlap li1 li2)
(setq olig (cons li2 olig))
)
)
(setq oligs (cons olig oligs))
(setq olig nil)
)
(setq oligs (unique (vl-remove-if '(lambda ( x ) (eq (length x) 1)) oligs)))
(foreach olig oligs
(setq olig (vl-sort olig '(lambda ( a b )
(>
(distance (cdr (assoc 10 (entget a))) (cdr (assoc 11 (entget a))))
(distance (cdr (assoc 10 (entget b))) (cdr (assoc 11 (entget b))))
)
)
)
)
(setq trf (/ 100.0 (length olig)))
(setq n 0)
(foreach li olig
(setq transparency (fix (- 100.0 (* (setq n (1+ n)) trf))))
(SetEntityTransparency li transparency)
)
)
)

(defun mk_txt ( p txt a )
(or *size* (setq *size* (getvar 'textsize)))
(entmake
(list
'(0 . "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
'(7 . "Standard")
(cons 1 txt)
(cons 10 p)
(cons 40 *size*)
(cons 50 a)
'(71 . 0)
'(72 . 1)
(cons 11 p)
'(210 0.0 0.0 1.0)
'(73 . 2)
)
)
)

(defun imgtxtblk2bb ( e / a evla p1 p2 rec )
(setq a (vla-get-rotation (setq evla (vlax-ename->vla-object e))))
(cond
( (vlax-property-available-p evla 'insertionpoint)
(vla-rotate evla (vla-get-insertionpoint evla) (- a))
)
( (vlax-property-available-p evla 'origin)
(vla-rotate evla (vla-get-origin evla) (- a))
)
)
(vla-getboundingbox evla 'p1 'p2)
(mapcar 'set (list 'p1 'p2) (mapcar 'vlax-safearray->list (list p1 p2)))
(setq rec (entmakex (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(90 . 4) '(70 . 1) '(38 . 0.0) (cons 10 p1) (cons 10 (polar p1 0.0 (setq d (- (car p2) (car p1))))) (cons 10 p2) (cons 10 (polar p2 pi d)) '(210 0.0 0.0 1.0))))
(cond
( (vlax-property-available-p evla 'insertionpoint)
(vla-rotate evla (vla-get-insertionpoint evla) a)
)
( (vlax-property-available-p evla 'origin)
(vla-rotate evla (vla-get-origin evla) a)
)
)
(cond
( (vlax-property-available-p evla 'insertionpoint)
(vla-rotate (vlax-ename->vla-object rec) (vla-get-insertionpoint evla) a)
)
( (vlax-property-available-p evla 'origin)
(vla-rotate (vlax-ename->vla-object rec) (vla-get-origin evla) a)
)
)
rec
)

(if (= 0 (getvar 'worlducs))
(progn
(command "_.UCS" "_W")
(setq ucsf t)
)
)
; (command "_.PLAN" "")
(if (not (tblsearch "LAYER" "0-DIM"))
(progn
(command "_.-LAYER" "_M" "0-DIM" "_C" "242")

(while (< 0 (getvar 'cmdactive)) (command ""))
)
)
(setvar 'clayer "0-DIM")
(prompt "\nSelect curve entities to dimension their lengths by each segment...")
(setq ss (ssget '((0 . "*POLYLINE,SPLINE,ELLIPSE,CIRCLE,ARC,LINE"))))
(initget 6)
(setq *size* (getdist (strcat "\nPick by two points or specify textsize : ")))

(if ss
(repeat (setq i (sslength ss))
(setq e (ssname ss (setq i (1- i))))
(if (wcmatch (cdr (assoc 0 (entget e))) "*POLYLINE")
(repeat (fix (setq k -1 ep (vlax-curve-getendparam e)))
(setq seglen (- (vlax-curve-getdistatparam e (1+ (setq k (1+ k)))) (vlax-curve-getdistatparam e k)))
(setq midsegpt (vlax-curve-getpointatparam e (+ k 0.5)))
(mk_txt midsegpt (rtos seglen 2 2) (cond
( (equal (setq a (angle '(0.0 0.0) (vlax-curve-getfirstderiv e (+ k 0.5)))) (* 1.5 pi) 1e-3)
(* 0.5 pi)
)
( (< (* 0.5 pi) (setq a (angle '(0.0 0.0) (vlax-curve-getfirstderiv e (+ k 0.5)))) (* 1.5 pi))
(- a pi)
)
( t a)
)
)
(setq txth (cdr (assoc 5 (entget (entlast)))))
(imgtxtblk2bb (entlast))
(setq bbh (cdr (assoc 5 (entget (entlast)))))
(setq li (entmakex (list '(0 . "LINE") (cons 10 midsegpt) (cons 11 midsegpt))))
(setq lil (cons li lil))
(setq handlst (cons (list bbh txth (cdr (assoc 5 (entget li)))) handlst))
(setq bblst (cons (handent bbh) bblst))
)
(progn
(setq len (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
(setq midpt (vlax-curve-getpointatparam e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)))
(mk_txt midpt (rtos len 2 2) (cond
( (equal (setq a (angle '(0.0 0.0) (vlax-curve-getfirstderiv e (/ (+ (vlax-curve-getstartparam e) (vlax-curve-getendparam e)) 2.0)))) (* 1.5 pi) 1e-3)
(* 0.5 pi)
)
( (list (list (vlax-variant-value (vla-intersectwith (vlax-ename->vla-object bb) (vlax-ename->vla-object x) acextendnone))))) nil t)) (vl-remove bb bblst)))
(vla-move (vlax-ename->vla-object bb) (vlax-3d-point (trans (cdr (assoc 10 (entget bb))) bb 0)) (vlax-3d-point (mapcar '/ (mapcar '+ (trans (cdr (assoc 10 (reverse (entget bb)))) bb 0) (trans (cdr (assoc 10 (entget bb))) bb 0)) '(2.0 2.0 2.0))))
(vla-move (vlax-ename->vla-object (handent (cadr (assoc (cdr (assoc 5 (entget bb))) handlst)))) (vlax-3d-point (trans (cdr (assoc 10 (entget bb))) bb 0)) (vlax-3d-point (mapcar '/ (mapcar '+ (trans (cdr (assoc 10 (reverse (entget bb)))) bb 0) (trans (cdr (assoc 10 (entget bb))) bb 0)) '(2.0 2.0 2.0))))
(entmod (subst (cons 11 (mapcar '+ (cdr (assoc 11 (entget (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst)))))) (mapcar '- (mapcar '/ (mapcar '+ (trans (cdr (assoc 10 (reverse (entget bb)))) bb 0) (trans (cdr (assoc 10 (entget bb))) bb 0)) '(2.0 2.0 2.0)) (trans (cdr (assoc 10 (entget bb))) bb 0)))) (assoc 11 (entget (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst))))) (entget (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst))))))
(if (equal (cdr (assoc 10 (entget (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst)))))) (cdr (assoc 11 (entget (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst)))))) 1e-6)
(progn
(setq lil (vl-remove (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst))) lil))
(entdel (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst))))
)
)
)
(if (equal (cdr (assoc 10 (entget (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst)))))) (cdr (assoc 11 (entget (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst)))))) 1e-6)
(progn
(setq lil (vl-remove (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst))) lil))
(entdel (handent (caddr (assoc (cdr (assoc 5 (entget bb))) handlst))))
)
)
)
(foreach bb bblst
(entdel bb)
)
(overlaplinesdisp lil)
(if ucsf
(command "_.UCS" "_P")
)
(princ)
)

Advertisements