(defun c:dimpolygons ( / *error* mr_IsPointInside mid adoc spc sel d i lw enx pl lwn enxn plni plno plnom plm clr)
(vl-load-com)
(defun *error* ( m )
(vla-endundomark adoc)
(if m
(prompt m)
)
(princ)
)
(setq clr (getvar "CLAYER"))
(command "-layer" "Make" "0-Dims" "color" "3" "" "")
(defun mr_IsPointInside ( pt ptlst / trianglst ptinsidetriangle-p trl )
(defun trianglst ( ptlst / unique LM:ListClockwise-p clockwise-p l p1 p2 p3 trl )
(defun unique ( l )
(if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
)
;; List Clockwise-p - Lee Mac
;; Returns T if the point list is clockwise oriented
(defun LM:ListClockwise-p ( lst )
(minusp
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
lst (cons (last lst) lst)
)
)
)
)
(defun clockwise-p ( p1 p2 p3 )
(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
)
(setq l ptlst)
(while (> (length ptlst) 3)
(setq p1 (car ptlst) p2 (cadr ptlst) p3 (caddr ptlst))
(cond
( (LM:ListClockwise-p ptlst)
(if
(and
(clockwise-p p1 p2 p3)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
)
( (not (LM:ListClockwise-p ptlst))
(if
(and
(not (clockwise-p p1 p2 p3))
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
)
)
)
(setq trl (cons (list (car ptlst) (cadr ptlst) (caddr ptlst)) trl))
trl
)
(defun ptinsidetriangle-p ( pt p1 p2 p3 )
(and
(not
(or
(inters pt p1 p2 p3)
(inters pt p2 p1 p3)
(inters pt p3 p1 p2)
)
)
(not
(or
(> (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
(> (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
(> (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
)
)
)
)
(setq trl (trianglst ptlst))
(vl-some (function (lambda ( x ) (ptinsidetriangle-p pt (car x) (cadr x) (caddr x)))) trl)
)
(defun mid ( p1 p2 )
(mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
)
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(setq spc (vla-get-block (vla-get-activelayout adoc)))
(if (not (tblsearch "DIMSTYLE" "SCAPE Standard"))
(Alert "SCAPE Standard dimension style not loaded")
(Command "-dimstyle" "r" "SCAPE Standard")
)
(prompt "\nSelect closed POLYGONS...")
(setq sel (ssget (list '(0 . "LWPOLYLINE") '(-4 . "&=") '(70 . 1) '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
(initget 7)
(setq d (getdist "\nPick or specify offset distance for dimensioning : "))
(if sel
(progn
(repeat (setq i (sslength sel))
(setq lw (ssname sel (setq i (1- i))))
(setq enx (entget lw))
(setq pl (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enx))) lw 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enx))))
(vla-offset (vlax-ename->vla-object lw) d)
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enxn))) lwn 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enxn))))
(if (not (mr_IsPointInside (car plni) pl))
(progn
(entdel lwn)
(vla-offset (vlax-ename->vla-object lw) (- d))
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enxn))) lwn 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enxn))))
)
)
(entdel lwn)
(setq plno (mapcar (function (lambda ( a b ) (mapcar (function +) a (mapcar (function -) a b)))) pl plni))
(setq plnom (mapcar (function (lambda ( a b ) (mid a b))) plno (cdr (reverse (cons (car plno) (reverse plno))))))
(mapcar (function (lambda ( a b c ) (vla-addDimAligned spc (vlax-3d-point a) (vlax-3d-point b) (vlax-3d-point c)))) pl (cdr (reverse (cons (car pl) (reverse pl)))) plnom)
(setq pl (reverse (cons (car pl) (reverse pl))))
(setq plm (mapcar (function (lambda ( a b ) (mid a b))) pl (cdr pl)))
(mapcar (function (lambda ( a b c d ) (vla-AddDim3PointAngular spc (vlax-3d-point a) (vlax-3d-point b) (vlax-3d-point c) (vlax-3d-point d)))) (cdr pl) plm (cdr (reverse (cons (car plm) (reverse plm))))
(cdr (reverse (cons (car plni) (reverse plni)))))
)
)
(prompt "\nEmpty sel. set... Retry routine with valid sel. set...")
)
(*error* nil)
(setvar "CLAYER" clr)
)
(command "_.-dimstyle" "A" "all" "")
; Function: ALE_LastEnt - original by Rune Wold and Michael Puckett (lastent)
;
; Version 1.01 - 20/12/2004 - modified with (and ...)
;
; Description:
; get the absolute last entity in the database,
; for problems in >=r15 in blocks with attrib, and polylines
;
; Arguments: none
;
; Return Values:
; An entity name;
; otherwise nil, if there are no entities in the current drawing
;
; Example: (setq marker (ALE_LastEnt)) see ALE_Ss-After
;
(defun c:dimpolygons ( / *error* mr_IsPointInside mid adoc spc sel d i lw enx pl lwn enxn plni plno plnom plm clr [color=red]lastent ss en[/color])
(vl-load-com)
(defun *error* ( m )
(vla-endundomark adoc)
(if m
(prompt m)
)
(princ)
)
[color=red](setq lastEnt (entlast))[/color]
(setq clr (getvar "CLAYER"))
(command "-layer" "Make" "0-Dims" "color" "3" "" "")
(defun mr_IsPointInside ( pt ptlst / trianglst ptinsidetriangle-p trl )
(defun trianglst ( ptlst / unique LM:ListClockwise-p clockwise-p l p1 p2 p3 trl )
(defun unique ( l )
(if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
)
;; List Clockwise-p - Lee Mac
;; Returns T if the point list is clockwise oriented
(defun LM:ListClockwise-p ( lst )
(minusp
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
lst (cons (last lst) lst)
)
)
)
)
(defun clockwise-p ( p1 p2 p3 )
(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
)
(setq l ptlst)
(while (> (length ptlst) 3)
(setq p1 (car ptlst) p2 (cadr ptlst) p3 (caddr ptlst))
(cond
( (LM:ListClockwise-p ptlst)
(if
(and
(clockwise-p p1 p2 p3)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
)
( (not (LM:ListClockwise-p ptlst))
(if
(and
(not (clockwise-p p1 p2 p3))
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
)
)
)
(setq trl (cons (list (car ptlst) (cadr ptlst) (caddr ptlst)) trl))
trl
)
(defun ptinsidetriangle-p ( pt p1 p2 p3 )
(and
(not
(or
(inters pt p1 p2 p3)
(inters pt p2 p1 p3)
(inters pt p3 p1 p2)
)
)
(not
(or
(> (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
(> (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
(> (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
)
)
)
)
(setq trl (trianglst ptlst))
(vl-some (function (lambda ( x ) (ptinsidetriangle-p pt (car x) (cadr x) (caddr x)))) trl)
)
(defun mid ( p1 p2 )
(mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
)
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(setq spc (vla-get-block (vla-get-activelayout adoc)))
(if (not (tblsearch "DIMSTYLE" "MVVA Standard Imperial"))
(Alert "MVVA Standard Imperial dimension style not loaded")
(Command "-dimstyle" "r" "MVVA Standard Imperial")
)
(prompt "\nSelect closed POLYGONS...")
(setq sel (ssget (list '(0 . "LWPOLYLINE") '(-4 . "&=") '(70 . 1) '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
(initget 7)
(setq d (getdist "\nPick or specify offset distance for dimensioning : "))
(if sel
(progn
(repeat (setq i (sslength sel))
(setq lw (ssname sel (setq i (1- i))))
(setq enx (entget lw))
(setq pl (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enx))) lw 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enx))))
(vla-offset (vlax-ename->vla-object lw) d)
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enxn))) lwn 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enxn))))
(if (not (mr_IsPointInside (car plni) pl))
(progn
(entdel lwn)
(vla-offset (vlax-ename->vla-object lw) (- d))
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enxn))) lwn 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enxn))))
)
)
(entdel lwn)
(setq plno (mapcar (function (lambda ( a b ) (mapcar (function +) a (mapcar (function -) a b)))) pl plni))
(setq plnom (mapcar (function (lambda ( a b ) (mid a b))) plno (cdr (reverse (cons (car plno) (reverse plno))))))
(mapcar (function (lambda ( a b c ) (vla-addDimAligned spc (vlax-3d-point a) (vlax-3d-point b) (vlax-3d-point c)))) pl (cdr (reverse (cons (car pl) (reverse pl)))) plnom)
(setq pl (reverse (cons (car pl) (reverse pl))))
(setq plm (mapcar (function (lambda ( a b ) (mid a b))) pl (cdr pl)))
(mapcar (function (lambda ( a b c d ) (vla-AddDim3PointAngular spc (vlax-3d-point a) (vlax-3d-point b) (vlax-3d-point c) (vlax-3d-point d)))) (cdr pl) plm (cdr (reverse (cons (car plm) (reverse plm))))
(cdr (reverse (cons (car plni) (reverse plni)))))
)
)
(prompt "\nEmpty sel. set... Retry routine with valid sel. set...")
)
[color=red](setq ss (ssadd))
(if (setq en (entnext LastEnt)) ;Check if there's a new entity created since the last one
(while en ;Step through all new entities
(ssadd en ss) ;Add it to the selection set
(setq en (entnext en)) ;Get the next entity
)
)
(command "_.-dimstyle" "Apply" ss "")[/color]
(*error* nil)
(setvar "CLAYER" clr)
)
To collect all the new entities find this routine.and use the last version:Code: [Select]; Function: ALE_LastEnt - original by Rune Wold and Michael Puckett (lastent)
;
; Version 1.01 - 20/12/2004 - modified with (and ...)
;
; Description:
; get the absolute last entity in the database,
; for problems in >=r15 in blocks with attrib, and polylines
;
; Arguments: none
;
; Return Values:
; An entity name;
; otherwise nil, if there are no entities in the current drawing
;
; Example: (setq marker (ALE_LastEnt)) see ALE_Ss-After
;
; Marc'Antonio Alessi
; Function: ALE_Ss-After thanks to Michael Puckett (Ss-After)
;
; Version 1.01 - 20/12/2004 for empty DWG
; Version 1.02 - 30/09/2005
; Version 1.03 - 06/05/2010 to support Bricscad
;
; Description:
; get a selection set of items after EntNam in the database
;
; Arguments: An entity name
;
; Return Values:
; A selection set;
; otherwise nil, if there are no entities after EntNam
;
; Examples:
; (setq marker (ALE_LASTENT)) ...create new entities...
; to include reference entity:
; (command "_.MOVE" (ALE_SS-AFTER marker) marker "" ...)
; Note: NOT valid if marker is a SEQEND of
; blocks with attrib or old polylines (PLINETYPE = 0)
;
; not include reference entity:
; (command "_.MOVE" (ALE_SS-AFTER marker) "" ...)
;
(defun ALE_Ss-After (EntNam / SelSet)
(cond
( (not EntNam) (ssget "_X" '((0 . "~VIEWPORT"))) ); "~VIEWPORT" x Bricscad
( (setq EntNam (entnext EntNam))
(setq SelSet (ssadd EntNam))
(while (setq EntNam (entnext EntNam))
(if (entget EntNam) (ssadd EntNam SelSet))
)
SelSet
)
)
)