Count Length of entities (LINEs, POLYLINEs, LWPOLYLINEs, ARCs, CIRCLEs, ELLIPSEs and SPLINEs) within viewport selected by user with table output


;;; Count Length of entities (LINEs,POLYLINEs,LWPOLYLINEs,ARCs,CIRCLEs,ELLIPSEs and SPLINEs) within viewport selected by user with table output
;;; Based on Jimmy Bergmark, Lee Mac, CAB, Kent Cooper, DannyNL, Marco Antonio Jacinto Perez and BeekeeCZ subroutines
;;; Close Solution for blocks counting inside closed polyline saved from:
;;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-request-block-count-inside-a-closed-polyline/td-p/7665364
;;; Final routine created by Igal Averbuh 2019 (combined from existing routines with some modifications)

;;; Rotates tables around their insertion points
;;; Created by BeekeeCZ
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-rotate-acad-table/td-p/8771700

(defun c:ROT ( / ss i ent dir pnt eng ucs)

(if (setq ss (ssget "L" '((0 . "ACAD_TABLE"))))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq dir (getpropertyvalue ent "Direction"))
(setq pnt (cdr (assoc 10 (entget ent))))
(setq ang (angle '(0 0 0) dir))
(setq ucs (angle '(0 0 0) (getvar 'UCSXDIR)))
(command "_.rotate" ent "" "_non" (trans pnt 0 1) "_R" (angtos ang (getvar 'AUNITS) 8) (angtos ucs (getvar 'AUNITS) 8))))
(princ)
)

;; ScaleAboutCenters.lsp [command name: SAC]
;; To Scale multiple objects, each About its own Center, by the same User-specified
;; scale factor.
;; Uses the middle of each object's bounding box as the base point for scaling, to
;; keep objects centered at approximately the same position in the drawing.
;; [For Mtext, that will be based on the defined Mtext box width, not the extents
;; of the content; for a Block or Text, the center of its extents in the drawing, not
;; its insertion point; for an Arc, the center of its extents, not its geometric center;
;; some entity types' (e.g. Spline's) bounding box can sometimes reach beyond
;; its extents and affect results slightly.]
;; Rejects selection of objects on locked Layers, or without a "center" [Rays, Xlines].
;; Stores scale factor; offers as default on subsequent use in same editing session.
;; Kent Cooper, 6 May 2014

(defun C:SAC (/ *error* cmde ss inc ent)
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); end if
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); end defun - *error*
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq *SACscl
(cond
( (getreal
(strcat
"\nEnter Scale Factor for blocks couning table : "
); strcat
); getreal
); User-input condition
(*SACscl); Enter on subsequent use [prior value]
(1); Enter on first use
); cond & *SACscl
ss (ssget "L" '((-4 . "")))
;; not objects on Locked Layers or without finite extents
); setq
(repeat (setq inc (sslength ss))
(setq ent (ssname ss (setq inc (1- inc))))
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
(command
".scale" ent "" "_none"
(mapcar '/ ; midpoint of bounding box
(mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt))
'(2 2 2)
); mapcar
*SACscl
); command
); repeat
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); defun
(vl-load-com)

;;; vp-outline.lsp
;;;
;;; Creates a polyline in modelspace that
;;; has the outline of the selected viewport.
;;; Supports clipped viewports. polyline is supported
;;; ellipse, spline, region and circle not supported at this point
;;; If vp-outline is called when in mspace it detects
;;; the active viewport.
;;;
;;; c:vp-outline
;;;
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2013 JTB World, All Rights Reserved
;;; Website: http://www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;; 2000-04-10
;;; 2003-11-19 Added support for drawing the outline in other ucs/view than world/current
;;;
;;; 2006-04-06 Added support for twisted views Tom Beauford
;;; 2013-06-08 Added support for circular viewports
;;;
;;; Should work on AutoCAD 2000 and newer
(vl-load-com)

(defun dxf (n ed) (cdr (assoc n ed)))

(defun ax:List->VariantArray (lst)
(vlax-Make-Variant
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbDouble
(cons 0 (- (length lst) 1))
)
lst
)
)
)

(defun c:vp (/ ad ss ent pl plist xy n vpbl vpur msbl msur ven vpno ok
circ)
(setq ad (vla-get-activedocument (vlax-get-acad-object)))
(if (= (getvar "tilemode") 0)
(progn
(if (= (getvar "cvport") 1)
(progn
(if (setq ss (ssget ":E:S" '((0 . "VIEWPORT"))))
(progn (setq ent (ssname ss 0))
(setq vpno (dxf 69 (entget ent)))
(vla-Display (vlax-ename->vla-object ent) :vlax-true)
(vla-put-mspace ad :vlax-true) ; equal (command "._mspace")
; this to ensure trans later is working on correct viewport
(setvar "cvport" vpno)
; (vla-put-mspace ad :vlax-false) ; equal (command "._pspace")
(setq ok T)
(setq ss nil)
)
)
)
(setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))
ok T
)
)
(if ok
(progn (setq circle nil)
(setq ven (vlax-ename->vla-object ent))
(if (/= 1 (logand 1 (dxf 90 (entget ent)))) ; detect perspective
(progn (if (= (vla-get-clipped ven) :vlax-false)
(progn ; not clipped
(vla-getboundingbox ven 'vpbl 'vpur)
(setq vpbl (trans (vlax-safearray->list vpbl) 3 2)
msbl (trans vpbl 2 1)
msbl (trans msbl 1 0)
vpur (trans (vlax-safearray->list vpur) 3 2)
msur (trans vpur 2 1)
msur (trans msur 1 0)
vpbr (list (car vpur) (cadr vpbl) 0)
msbr (trans vpbr 2 1)
msbr (trans msbr 1 0)
vpul (list (car vpbl) (cadr vpur) 0)
msul (trans vpul 2 1)
msul (trans msul 1 0)
plist (list (car msbl)
(cadr msbl)
(car msbr)
(cadr msbr)
(car msur)
(cadr msur)
(car msul)
(cadr msul)
)
)
)
(progn ; clipped
(setq pl (entget (dxf 340 (entget ent))))
(if (= (dxf 0 pl) "CIRCLE")
(setq circle T)
(progn (setq plist (vla-get-coordinates
(vlax-ename->vla-object (dxf -1 pl))
)
plist (vlax-safearray->list (vlax-variant-value plist))
n 0
pl nil
)
(repeat (/ (length plist) 2)
(setq xy (trans (list (nth n plist) (nth (1+ n) plist)) 3 2)
xy (trans xy 2 1)
xy (trans xy 1 0)
pl (cons (car xy) pl)
pl (cons (cadr xy) pl)
n (+ n 2)
)
)
(setq plist (reverse pl))
)
)
)
)
(if circle
(vla-AddCircle
(vla-get-ModelSpace ad)
(ax:List->VariantArray
(trans (trans (trans (dxf 10 pl) 1 0) 2 1) 3 2)
)
(/ (dxf 40 pl) (caddr (trans '(0 0 1) 2 3)))
)
(vla-Put-Closed
(vla-AddLightWeightPolyline
(vla-get-ModelSpace ad)
(ax:List->VariantArray plist)
)
:vlax-True
)
)
)
)
)
)
)
)
(if ss
(vla-put-mspace ad :vlax-false)
) ; equal (command "._pspace"))
(princ)
)

;;;=======================[ BreakObjects.lsp ]==============================
;;; Author: Copyright© 2006-2019 Charles Alan Butler
;;; Contact @ http://www.TheSwamp.org
;;; http://www.theswamp.org/index.php?topic=10370.0
;;; Version: 2.3 June 6,2019
;;; Purpose: Break All selected objects
;;; permitted objects are lines, lwplines, plines, splines,
;;; ellipse, circles & arcs
;;;
;;; Function c:MyBreak - DCL for selecting the routines
;;; Function c:BreakAll - Break all objects selected with each other
;;; Function c:BreakwObject - Break many objects with a single object
;;; Function c:BreakObject - Break a single object with other objects
;;; Function c:BreakWith - Break selected objects with other selected objects
;;; Function c:BreakTouching - Break objects touching selected objects
;;; Function c:BreakSelected - Break selected objects with any objects that touch it
;;; Function c:BreakRemove - Break selected object with any objects that touch it & remove
;;; every other new segment, start with selected object
;;; Revision 1.8 Added Option for Break Gap greater than zero
;;; NEW r1.9 c:BreakWlayer - Break objects with objects on a layer
;;; NEW r1.9 c:BreakWithTouching - Break touching objects with selected objects
;;; Revision 2.0 Fixed a bug when point to break is at the end of object
;;; Revision 2.1 Fixed another bug when point to break is at the end of object
;;; Revision 2.2 Fixed another bug when closed objects are to be broken
;;; Revision 2.3 test for BricsCAD 06.06.2019
;;;
;;; Function break_with - main break function called by all others and
;;; returns a list of new enames, see c:BreakAll
;;; for an example of using the return list
;;;
;;; Requirements: objects must have the same z-value
;;; Restrictions: Does not Break objects on locked layers
;;; Returns: none
;;;
;;;=====================================================================
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;
;;; ;
;;; You are hereby granted permission to use, copy and modify this ;
;;; software without charge, provided you do so exclusively for ;
;;; your own use or for use by others in your organization in the ;
;;; performance of their normal duties, and provided further that ;
;;; the above copyright notice appears in all copies and both that ;
;;; copyright notice and the limited warranty and restricted rights ;
;;; notice below appear in all supporting documentation. ;
;;;=====================================================================

(setq Brics (wcmatch (getvar 'acadver) "*BricsCAD*" )) ; test for BricsCAD 06.06.19

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
;;
;; return list of enames of new objects

(vl-load-com)

(princ "\nCalculating Break Points, Please Wait.\n")

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;; return T if entity is on a locked layer
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)

;; return a list of objects from a selection set
;| (defun ssget->vla-list (ss)
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
)|;
(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)

;; return a list of lists grouped by 3 from a flat list
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new)
)

;;=====================================
;; return a list of intersect points
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
))))))
iplist
)
)

;;========================================
;; Break entity at break points in list
;;========================================
;; New as per version 1.8 [BrkGap] --- This subroutine has been re-written
;; Loop through the break points breaking the entity
;; If the entity is not a closed entity then a new object is created
;; This object is added to a list. When break points don't fall on the current
;; entity the list of new entities are searched to locate the entity that the
;; point is on so it can be broken.
;; "Break with a Gap" has been added to this routine. The problem faced with
;; this method is that sections to be removed may lap if the break points are
;; too close to each other. The solution is to create a list of break point pairs
;; representing the gap to be removed and test to see if there i an overlap. If
;; there is then merge the break point pairs into one large gap. This way the
;; points will always fall on an object with one exception. If the gap is too near
;; the end of an object one break point will be off the end and therefore that
;; point will need to be replaced with the end point.
;; NOTE: in ACAD2000 the (vlax-curve-getdistatpoint function has proven unreliable
;; so I have used (vlax-curve-getdistatparam in most cases
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
brkptE brkpt result GapFlg result ignore dist tmppt
#ofpts 2gap enddist lastent obj2break stdist
)
(or BrkGap (setq BrkGap 0.0)) ; default to 0
(setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point

(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
GapFlg (not (zerop BrkGap)) ; gap > 0
closedobj (vlax-curve-isclosed obj2break)
)
;; when zero gap no need to break at end points, not closed
(if (and (zerop Brkgap)(not closedobj)) ; Revision 2.2
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)))
brkptlst)
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break x))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) ( 0
;; Brkptlst starts as the break point and then a list of pairs of points
;; is creates as the break points
(progn
;; create a list of list of break points
;; ((idx# stpoint distance)(idx# endpoint distance)...)
(setq idx 0)
(foreach brkpt brkptlst

;; ----------------------------------------------------------
;; create start break point, then create end break point
;; ((idx# startpoint distance)(idx# endpoint distance)...)
;; ----------------------------------------------------------
(setq dist (cadr brkpt)) ; distance to center of gap
;; subtract gap to get start point of break gap
(cond
((and (minusp (setq stDist (- dist BrkGap))) closedobj )
(setq stdist (+ (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)) stDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((minusp stDist) ; off start of object so get startpoint
(setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; add gap to get end point of break gap
(cond
((and (> (setq stDist (+ dist BrkGap))
(setq endDist (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)))) closedobj )
(setq stdist (- stDist endDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((> stDist endDist) ; off end of object so get endpoint
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getendparam obj2break))
endDist) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; -------------------------------------------------------
(setq idx (1+ IDX))
) ; foreach brkpt brkptlst

(setq dlst (reverse dlst))
;; remove the points of the gap segments that overlap
(setq idx -1
2gap (* BrkGap 2)
#ofPts (length Brkptlst)
)
(while ( #ofPts 1)
(<= (+(- (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break))
(cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
(progn
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (cadr (reverse result)) result) ; get last end point
result (cdr (reverse result))
result (reverse (cdr result)))
)
)
)
;; Break Gap Overlaps
(( 0
(setq brkptS (car brkpt)
brkptE (cadr brkpt))
(setq brkptS (car brkpt)
brkptE brkptS)
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj2break tmppt))))
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while (and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj tmppt)))
(null (setq obj2break obj)) ; switch objects, null causes exit
t
)
)
)
)
)
)
)
;| ;; ver 2.0 fix - removed this code as there are cases where the break point
;; is at the end of a line which is not a valid break but does no harm
(if (and brkobjlst idx (minusp idx)
(null (alert (strcat "Error - point not on object"
"\nPlease report this error to"
"\n CAB at TheSwamp.org"))))
(exit)
)
|;
;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB -------------

;; Handle any objects that can not be used with the Break Command
;; using one point, gap of 0.000001 is used
(setq closedobj (vlax-curve-isclosed obj2break))
(if GapFlg ; gap > 0
(if closedobj
(progn ; need to break a closed object
(setq brkpt2 (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
(command "._break" obj2break "_non" (trans brkpt2 0 1)
"_non" (trans brkptE 0 1))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(setq BrkptE brkpt2)
)
)
;; single breakpoint ----------------------------------------------------
;|(if (and closedobj ; problems with ACAD200 & this code
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001))))
)
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001)))

)|;
(if (and closedobj
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
)
) ; endif

;; (if (null brkptE) (princ)) ; debug

(setq LastEnt (GetLastEnt))
(command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast))))
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
) ; endif brkptlst

) ; defun break_obj

;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;===================================
;; CAB - return a list of new enames
(defun GetNewEntities (ename / new)
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (setq new (cons ename new)))
)
)
((alert "Ename wrong type."))
)
new
)

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(setq LastEntInDatabase (GetLastEnt))
(if (and ss2brk ss2brkwith)
(progn
(setq oc 0
ss2brkwithList (ssget->vla-list ss2brkwith))
(if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
(setq *BrkVerbose* t)
)
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
;; CREATE a list of entity & it's break points
(foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj ss2brkwithList
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
)
(and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
)
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
)
)
)
)

(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
;; masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk) Gap)
)
)
)
)
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D O F M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;======================
;; Redraw ss with mode
;;======================
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)

;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq
ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D M A I N F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;===============================================
;; Break all objects selected with each other
;;===============================================
(defun c:BreakAll (/ cmd ss NewEnts AllEnts tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;===========================================
;; Break a single object with other objects
;;===========================================
(defun c:BreakObject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nSelect single object to break: ")
(if (and (setq ss1 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 4)))
(Break_with ss1 ss2 nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================
;; Break many objects with a single object
;;==========================================
(defun c:BreakWobject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select single object to break with: ***"))
(setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================
;; Break objects with objects on a layer
;;==========================================
;; New 08/01/2008
(defun c:BreakWlayer (/ cmd ss1 ss2 tmp lay)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\n*** Select single object for break layer: ***")

(if (and (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq lay (assoc 8 (entget (ssname ss2 0))))
(setq ss2 (ssget "_X" (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
lay (cons 410 (getvar "ctab")))))
(not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss1 (ssget (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 8 (strcat "~" (cdr lay))))))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;======================================================
;; Break selected objects with other selected objects
;;======================================================
(defun c:BreakWith (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;=============================================
;; Break objects touching selected objects
;;=============================================

(defun c:BT (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 1)) ; default
(initget 4) ; no negative numbers

;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if (and (not (prompt ""))
(setq ss2 (ssget "L" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;=================================================
;; Break touching objects with selected objects
;;=================================================
;; New 08/01/2008
(defun c:BreakWithTouching (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(prompt "\nSelect object(s) to break with & press enter: ")
(if (and (setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq tlst (gettouching ss2))
)
(progn
(setq tlst (vl-remove-if '(lambda (x)(ssmemb x ss2)) tlst)) ; remove if in picked ss
(mapcar '(lambda (x) (ssadd x ss1)) tlst) ; convert to a selection set
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================================
;; Break selected objects with any objects that touch it
;;==========================================================

(defun c:BreakSelected (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap. ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil Bgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================================
;; Break selected object with any objects that touch it and remove every
;; other segment of the broken object, start with selected object
;;==========================================================

(defun c:BreakRemove (/ cmd ss1 ss2 tmp entlst ename ent en e dist)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(setq Bgap 0
tmp 1)
;; get object to break
(prompt "\nBreak selected object with any objects that touch it.")
(if (and (not (prompt "\nSelect object to break with touching & press enter: "))
(setq ss2 (ssget "_+.:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (setq touch (gettouching ss2)))
)
(setq entlst (break_with ss2 ss1 nil Bgap)) ; ss2break ss1breakwith (flag nil = not to break with self)
)
(if (not (member (setq ename (ssname ss2 0)) entlst))(setq entlst (append entlst (list ename))))
(setq pt (cadr(cadddr(car (ssnamex ss2 0))))) ; pick point for ss2
(foreach ent entlst ; find the new object that is at the picked spot
(cond
((null dist)
(if (setq p (vlax-curve-getclosestpointto ent pt))
(setq dist (distance pt p)
en ent)))
((setq p (vlax-curve-getclosestpointto ent pt))
(if ( (setq lp (1- lp)) 0)
(setq ln (read-line fn)) ; get a line from file
(if (vl-string-search rvflag ln)
(setq lp 0)
)
)
(close fn) ; close the open file handle
(if (= lp -1)
nil ; no new dcl needed
t ; flag to create new file
)
)
t ; flag to create new file
)
)
(if (null(wcmatch (strcase fname) "*`.DCL"))
(setq fname (strcat fname ".DCL"))
)
(if (dcl-rev-check fname)
;; create dcl file in same directory as ACAD.PAT
(progn
(setq patfn (if Brics "default.pat" "ACAD.PAT")
acadfn (findfile patfn)
;; kdub revised 060619 ;; fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname)
fn (strcat (vl-filename-directory acadfn) "\\" fname)
fn (open fn "w")
)

(foreach x (list
"// WARNING file will be recreated if you change the next line"
rvflag
"//BreakAll.DCL"
"BreakDCL : dialog { label = \"[ Break All or Some by CAB v2.3 ]\";"
" : text { label = \"--==--\"; "
" key = \"tm\"; alignment = centered; fixed_width = true;}"
" spacer_1;"
" : button { key = \"b1\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break all objects selected with each other\";} "
" : button { key = \"b2\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break selected objects with other selected objects\";}"
" : button { key = \"b3\"; mnemonic = \"T\"; alignment = centered;"
" label = \" Break selected objects with any objects that touch it\";}"
" spacer_1;"
" : row { spacer_0;"
" : edit_box {key = \"gap\" ; width = 8; mnemonic = \"G\"; label = \"Gap\"; fixed_width = true;}"
" : button { label = \"Help\"; key = \"help\"; mnemonic = \"H\"; fixed_width = true;} "
" cancel_button;"
" spacer_0;"
" }"
"}"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\nDCL file created, please restart the routine"
"\n again if an error occures."))
t ; return True, file created
)
t ; return True, file found
)
) ; end defun

;;==============================
;; BreakAll Dialog Routine
;;==============================
(defun c:MyBreak(/ dclfile dcl# RunDCL BreakHelp cmd txt2num)
;; return number or nil
(defun txt2num (txt / num)
(if txt
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
)
(if (numberp num)
num
)
)
(defun mydonedialog (flag)
(setq DCLgap (txt2num (get_tile "gap")))
(done_dialog flag)
)
(defun RunDCL (/ action)
(or DCLgap (setq DCLgap 0)) ; error trap value
(action_tile "b1" "(mydonedialog 1)")
(action_tile "b2" "(mydonedialog 2)")
(action_tile "b3" "(mydonedialog 3)")
(action_tile "gap" "(setq DCLgap (txt2num value$))")
(set_tile "gap" (rtos DCLgap))
(action_tile "help" "(BreakHelp)")
(action_tile "cancel" "(done_dialog 0)")
(setq action (start_dialog))
(or DCLgap (setq DCLgap 0)) ; error trap value
(setq DCLgap (max DCLgap 0)) ; nu negative numbers

(cond
((= action 1) ; BreakAll
(command "_.undo" "_begin")
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil DCLgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(command "_.undo" "_end")
(princ)
)

((= action 2) ; BreakWith
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil DCLgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

)
((= action 3) ; BreakSelected
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil DCLgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)
)
)
)
(defun BreakHelp ()
(alert
(strcat
"BreakAll.lsp (c) 2007-2019 Charles Alan Butler\n\n"
"This LISP routine will break objects based on the routine you select.\n"
"It will not break objects on locked layers and objects must have the same z-value.\n"
"Object types are limited to LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE\n"
"BreakAll - Break all objects selected with each other\n"
"BreakwObject - Break many objects with a single object\n"
"BreakObject - Break a single object with many objects \n"
"BreakWith - Break selected objects with other selected objects\n"
"BreakTouching - Break objects touching selected objects\n"
"BreakSelected - Break selected objects with any objects that touch it\n"
" The Gap distance is the total opening created.\n"
"You may run each routine by entering the function name at the command line.\n"
"For updates & comments contact Charles Alan Butler AKA CAB at TheSwamp.org.\n")
)
)

;;================================================================
;; Start of Routine
;;================================================================
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq dclfile "BreakAll.dcl")
(cond
((not (create_Breakdcl dclfile))
(prompt (strcat "\nCannot create " dclfile "."))
)
(( (setq n (1- n)) -1)
(if (and
(setq ss1 (ssget WC (mapcar 'cdr (vl-remove-if-not '(lambda (item) (= (car item) 10)) (entget (ssname pSS n))))))
(setq m (sslength ss1)) ;number of objects inside of polyline
)
(while (> (setq m (1- m)) -1)
(setq en (ssname ss1 m)) ;en = list of entity names inside of polyline
(ssadd en ss)

)
)

(setq ss1 nil)
(gc)
)
)
(if (> (sslength ss) 1)
(sssetfirst nil ss)
)
)

;Count selected objects length and area by layer
;Stefan M. 22.09.2016
(defun C:LAY ( / *error* acdoc ss p i e a d l s h dz) (vl-load-com)
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
dz (getvar 'dimzin))
(vla-startundomark acdoc)
(setvar 'dimzin 1)

(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(setvar 'dimzin dz)
(if
(= 8 (logand (getvar 'undoctl) 8))
(vla-endundomark acdoc)
)
(princ)
)

(if
(and
(setq ss (ssget "P" '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE,HATCH"))))
(setq p (getpoint "\nTable scale depend on annotation scale.\nSpecify table insert point: "))
)
(progn
(repeat
(setq i (sslength ss))
(setq e (vlax-ename->vla-object (ssname ss (setq i (1- i))))
a (vla-get-layer e)
)
(if
(setq h (eq (vla-get-objectname e) "AcDbHatch"))
(setq s (vla-get-area e))
(setq d (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
)
(if
(setq o (assoc a l))
(if h
(setq l (subst (list a (cadr o) (+ (caddr o) s)) o l))
(setq l (subst (list a (+ (cadr o) d) (caddr o)) o l))
)
(if h
(setq l (cons (list a 0.0 s) l))
(setq l (cons (list a d 0.0) l))
)
)
)
(setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
(insert_table l p)
)
)
(*error* nil)
(princ)
)

(defun insert_table (lst pct / tab row col ht i n space )
(setq space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
ht (/ 2.5 (cond ((getvar 'cannoscalevalue)) (1.0)))
pct (trans pct 1 0)
n (trans '(1 0 0) 1 0 T)
tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 2 (length lst)) (length (car lst)) (* 2.5 ht) ht))
)
(vlax-put tab 'direction n)

(mapcar
(function
(lambda (rowType)
(vla-SetTextStyle tab rowType (getvar 'textstyle))
(vla-SetTextHeight tab rowType ht)
)
)
'(2 4 1)
)

(vla-put-HorzCellMargin tab (* 0.14 ht))
(vla-put-VertCellMargin tab (* 0.14 ht))

(setq lst (cons '("Layer" "Length") lst))

(setq i 0)
(foreach col (apply 'mapcar (cons 'list lst))
(vla-SetColumnWidth tab i
(apply
'max
(mapcar
'(lambda (x)
((lambda (txb) (+ (abs (- (caadr txb) (caar txb))) (* 2.0 ht)))
(textbox
(list
(cons 1
(cond
((eq (type x) 'STR) x)
((eq (type x) 'INT) (itoa x))
((eq (type x) 'REAL) (rtos x))
)
)
(cons 7 (getvar 'textstyle))
(cons 40 ht))
)
)
)
col
)
)
)
(setq i (1+ i))
)

(setq lst (cons '("TITLE") lst))

(setq row 0)
(foreach r lst
(setq col 0)
(foreach c r
(if
(not (eq c 0))
(progn
(vla-SetText tab row col c)
(vla-SetCellDataType
tab row col
(cdr (assoc (type c) '((STR . 4) (REAL . 2) (INT . 1))))
acUnitless
)
(vla-setCellAlignment tab row col acMiddleCenter)
)
)
(setq col (1+ col))
)
(vla-SetRowHeight tab row (* 1.6 ht))
(setq row (1+ row))
)
)

(defun c:igal () ;; Create text style arial.ttf
(command "-style" "igal" "arial.ttf" "" "" "0" "" "" "")
)

;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

(defun c:vlc()
(c:igal)
(command "_.-LAYER" "_T" "0-LENGTH-COUNTING" "_U" "0-LENGTH-COUNTING" "_M" "0-LENGTH-COUNTING" "_C" 1 "0-LENGTH-COUNTING" "")
(princ "\n Select ViewPort for Counting Area Definition...")
(c:vp) ; create vport outline
(setvar "tilemode" 1)
(c:bt) ; cut objects by vport outline
(setvar "tilemode" 0)
(command "._pspace")
(princ "\n Select ViewPort for LENGTH Counting Inside Defined Vport...")
(c:vp) ; create vport outline
(c:sip) ; select objects inside vport outline polyline
(c:lay) ; count length of entities inside selected vport
(setvar "osmode" 0)

(command "._chspace" "L" "" "")
(c:rot)
(c:sac)
(setvar "osmode" 167)
)

Count strings within viewport selected by user with table output


;;; Count strings within viewport selected by user with table output
;;; Based on Jimmy Bergmark, Lee Mac, Kent Cooper, DannyNL and Marco Antonio Jacinto Perez and BeekeeCZ subroutines
;;; Close Solution for blocks counting inside closed polyline saved from:
;;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-request-block-count-inside-a-closed-polyline/td-p/7665364
;;; Final routine created by Igal Averbuh 2019 (combined from existing routines with some modifications)

;;; Rotates tables around their insertion points
;;; Created by BeekeeCZ
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-rotate-acad-table/td-p/8771700

(defun c:ROT ( / ss i ent dir pnt eng ucs)

(if (setq ss (ssget "L" '((0 . "ACAD_TABLE"))))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq dir (getpropertyvalue ent "Direction"))
(setq pnt (cdr (assoc 10 (entget ent))))
(setq ang (angle '(0 0 0) dir))
(setq ucs (angle '(0 0 0) (getvar 'UCSXDIR)))
(command "_.rotate" ent "" "_non" (trans pnt 0 1) "_R" (angtos ang (getvar 'AUNITS) 8) (angtos ucs (getvar 'AUNITS) 8))))
(princ)
)

;; ScaleAboutCenters.lsp [command name: SAC]
;; To Scale multiple objects, each About its own Center, by the same User-specified
;; scale factor.
;; Uses the middle of each object's bounding box as the base point for scaling, to
;; keep objects centered at approximately the same position in the drawing.
;; [For Mtext, that will be based on the defined Mtext box width, not the extents
;; of the content; for a Block or Text, the center of its extents in the drawing, not
;; its insertion point; for an Arc, the center of its extents, not its geometric center;
;; some entity types' (e.g. Spline's) bounding box can sometimes reach beyond
;; its extents and affect results slightly.]
;; Rejects selection of objects on locked Layers, or without a "center" [Rays, Xlines].
;; Stores scale factor; offers as default on subsequent use in same editing session.
;; Kent Cooper, 6 May 2014

(defun C:SAC (/ *error* cmde ss inc ent)
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); end if
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); end defun - *error*
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq *SACscl
(cond
( (getreal
(strcat
"\nEnter Scale Factor for blocks couning table : "
); strcat
); getreal
); User-input condition
(*SACscl); Enter on subsequent use [prior value]
(1); Enter on first use
); cond & *SACscl
ss (ssget "L" '((-4 . "")))
;; not objects on Locked Layers or without finite extents
); setq
(repeat (setq inc (sslength ss))
(setq ent (ssname ss (setq inc (1- inc))))
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
(command
".scale" ent "" "_none"
(mapcar '/ ; midpoint of bounding box
(mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt))
'(2 2 2)
); mapcar
*SACscl
); command
); repeat
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); defun
(vl-load-com)

;;; vp-outline.lsp
;;;
;;; Creates a polyline in modelspace that
;;; has the outline of the selected viewport.
;;; Supports clipped viewports. polyline is supported
;;; ellipse, spline, region and circle not supported at this point
;;; If vp-outline is called when in mspace it detects
;;; the active viewport.
;;;
;;; c:vp-outline
;;;
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2013 JTB World, All Rights Reserved
;;; Website: http://www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;; 2000-04-10
;;; 2003-11-19 Added support for drawing the outline in other ucs/view than world/current
;;;
;;; 2006-04-06 Added support for twisted views Tom Beauford
;;; 2013-06-08 Added support for circular viewports
;;;
;;; Should work on AutoCAD 2000 and newer
(vl-load-com)

(defun dxf (n ed) (cdr (assoc n ed)))

(defun ax:List->VariantArray (lst)
(vlax-Make-Variant
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbDouble
(cons 0 (- (length lst) 1))
)
lst
)
)
)

(defun c:vp-outline (/ ad ss ent pl plist xy n vpbl vpur msbl msur ven vpno ok
circ)
(setq ad (vla-get-activedocument (vlax-get-acad-object)))
(if (= (getvar "tilemode") 0)
(progn
(if (= (getvar "cvport") 1)
(progn
(if (setq ss (ssget ":E:S" '((0 . "VIEWPORT"))))
(progn (setq ent (ssname ss 0))
(setq vpno (dxf 69 (entget ent)))
(vla-Display (vlax-ename->vla-object ent) :vlax-true)
(vla-put-mspace ad :vlax-true) ; equal (command "._mspace")
; this to ensure trans later is working on correct viewport
(setvar "cvport" vpno)
; (vla-put-mspace ad :vlax-false) ; equal (command "._pspace")
(setq ok T)
(setq ss nil)
)
)
)
(setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))
ok T
)
)
(if ok
(progn (setq circle nil)
(setq ven (vlax-ename->vla-object ent))
(if (/= 1 (logand 1 (dxf 90 (entget ent)))) ; detect perspective
(progn (if (= (vla-get-clipped ven) :vlax-false)
(progn ; not clipped
(vla-getboundingbox ven 'vpbl 'vpur)
(setq vpbl (trans (vlax-safearray->list vpbl) 3 2)
msbl (trans vpbl 2 1)
msbl (trans msbl 1 0)
vpur (trans (vlax-safearray->list vpur) 3 2)
msur (trans vpur 2 1)
msur (trans msur 1 0)
vpbr (list (car vpur) (cadr vpbl) 0)
msbr (trans vpbr 2 1)
msbr (trans msbr 1 0)
vpul (list (car vpbl) (cadr vpur) 0)
msul (trans vpul 2 1)
msul (trans msul 1 0)
plist (list (car msbl)
(cadr msbl)
(car msbr)
(cadr msbr)
(car msur)
(cadr msur)
(car msul)
(cadr msul)
)
)
)
(progn ; clipped
(setq pl (entget (dxf 340 (entget ent))))
(if (= (dxf 0 pl) "CIRCLE")
(setq circle T)
(progn (setq plist (vla-get-coordinates
(vlax-ename->vla-object (dxf -1 pl))
)
plist (vlax-safearray->list (vlax-variant-value plist))
n 0
pl nil
)
(repeat (/ (length plist) 2)
(setq xy (trans (list (nth n plist) (nth (1+ n) plist)) 3 2)
xy (trans xy 2 1)
xy (trans xy 1 0)
pl (cons (car xy) pl)
pl (cons (cadr xy) pl)
n (+ n 2)
)
)
(setq plist (reverse pl))
)
)
)
)
(if circle
(vla-AddCircle
(vla-get-ModelSpace ad)
(ax:List->VariantArray
(trans (trans (trans (dxf 10 pl) 1 0) 2 1) 3 2)
)
(/ (dxf 40 pl) (caddr (trans '(0 0 1) 2 3)))
)
(vla-Put-Closed
(vla-AddLightWeightPolyline
(vla-get-ModelSpace ad)
(ax:List->VariantArray plist)
)
:vlax-True
)
)
)
)
)
)
)
)
(if ss
(vla-put-mspace ad :vlax-false)
) ; equal (command "._pspace"))
(princ)
)

;;--------------------=={ Text Count }==----------------------;;
;; ;;
;; Counts the number of occurrences of each string in a ;;
;; selection and produces a report in an ACAD Table object ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Version 1.0 - 07.11.2010 ;;
;; First Release. ;;
;;------------------------------------------------------------;;
;; Version 1.1 - 05.08.2011 ;;
;; Added Dimensions Override Text & MLeaders ;;
;; Updated 'AddTable' to account for Annotative Text Styles. ;;
;;------------------------------------------------------------;;

(defun c:tc
( /

*error*
_StartUndo
_EndUndo
_Assoc++
_SumAttributes
_GetTextString
_ApplyFooToSelSet

acdoc
acspc
alist
data
pt

)

;;------------------------------------------------------------;;

(defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)

;;------------------------------------------------------------;;

(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)

;;------------------------------------------------------------;;

(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)

;;------------------------------------------------------------;;

(defun _Assoc++ ( key alist )
(
(lambda ( pair )
(if pair
(subst (list key (1+ (cadr pair))) pair alist)
(cons (list key 1) alist)
)
)
(assoc key alist)
)
)

;;------------------------------------------------------------;;

(defun _SumAttributes ( entity alist )
(while
(not
(eq "SEQEND"
(cdr
(assoc 0
(entget
(setq entity (entnext entity))
)
)
)
)
)
(setq alist (_Assoc++ (_GetTextString entity) alist))
)
)

;;------------------------------------------------------------;;

(defun _GetTextString ( entity )
(
(lambda ( string )
(mapcar
(function
(lambda ( pair )
(if (member (car pair) '(1 3))
(setq string (strcat string (cdr pair)))
)
)
)
(entget entity)
)
string
)
""
)
)

;;------------------------------------------------------------;;

(defun _ApplyFooToSelSet ( foo ss / i )
(if ss (repeat (setq i (sslength ss)) (foo (ssname ss (setq i (1- i))))))
)

;;------------------------------------------------------------;;

(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace))
)
(cond
( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER))))))
(princ "\nCurrent Layer Locked.")
)
( (not (vlax-method-applicable-p acspc 'AddTable))
(princ "\nTable Object not Available in this version.")
)
( (and
(setq data
(_ApplyFooToSelSet
(lambda ( entity / typ )
(setq alist
(cond
( (eq "INSERT" (setq typ (cdr (assoc 0 (entget entity)))))
(_SumAttributes entity alist)
)
( (eq "MULTILEADER" typ)
(_Assoc++ (cdr (assoc 304 (entget entity))) alist)
)
( (wcmatch typ "*DIMENSION")
(_Assoc++ (cdr (assoc 1 (entget entity))) alist)
)
( (_Assoc++ (_GetTextString entity) alist) )
)
)
)
(ssget "P"
'(
(-4 . "<OR")
(0 . "TEXT,MTEXT,MULTILEADER")
(-4 . "")
(-4 . "")
(-4 . "OR>")
)
)
)
)
(setq pt (getpoint "\nSpecify Point for Table: "))
)
(_StartUndo acdoc)
(LM:AddTable acspc (trans pt 1 0) "String Count"
(cons (list "String" "Instances")
(vl-sort
(mapcar
(function
(lambda ( x ) (list (car x) (itoa (cadr x))))
)
data
)
(function (lambda ( a b ) ( (setq n (1- n)) -1)
(if (and
(setq ss1 (ssget WC (mapcar 'cdr (vl-remove-if-not '(lambda (item) (= (car item) 10)) (entget (ssname pSS n))))))
(setq m (sslength ss1)) ;number of objects inside of polyline
)
(while (> (setq m (1- m)) -1)
(setq en (ssname ss1 m)) ;en = list of entity names inside of polyline
(ssadd en ss)

)
)

(setq ss1 nil)
(gc)
)
)
(if (> (sslength ss) 1)
(sssetfirst nil ss)
)
)

;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

(defun c:vsc()
(command "_.-LAYER" "_T" "0-STRING-COUNTING" "_U" "0-STRING-COUNTING" "_M" "0-STRING-COUNTING" "_C" 1 "0-STRING-COUNTING" "")
(princ "\n Select ViewPort for STRING Counting...")
(c:vp-outline)
(c:sip)
(c:tc)
(setvar "osmode" 0)

(command "._chspace" "L" "" "")
(c:rot)
(c:sac)
(setvar "osmode" 167)
)
;(c:vsc)

Count blocks within viewport selected by user with table output


;;; Count blocks within viewport selected by user with table output
;;; Based on Jimmy Bergmark, Lee Mac, Kent Cooper, DannyNL and Marco Antonio Jacinto Perez and BeekeeCZ subroutines
;;; Solution for blocks counting inside closed polyline saved from:
;;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-request-block-count-inside-a-closed-polyline/td-p/7665364
;;; Final routine created by Igal Averbuh 2019 (combined from existing routines with some modifications)

;;; Rotates tables around their insertion points
;;; Created by BeekeeCZ
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-rotate-acad-table/td-p/8771700

(defun c:ROT ( / ss i ent dir pnt eng ucs)

(if (setq ss (ssget "L" '((0 . "ACAD_TABLE"))))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq dir (getpropertyvalue ent "Direction"))
(setq pnt (cdr (assoc 10 (entget ent))))
(setq ang (angle '(0 0 0) dir))
(setq ucs (angle '(0 0 0) (getvar 'UCSXDIR)))
(command "_.rotate" ent "" "_non" (trans pnt 0 1) "_R" (angtos ang (getvar 'AUNITS) 8) (angtos ucs (getvar 'AUNITS) 8))))
(princ)
)

;; ScaleAboutCenters.lsp [command name: SAC]
;; To Scale multiple objects, each About its own Center, by the same User-specified
;; scale factor.
;; Uses the middle of each object's bounding box as the base point for scaling, to
;; keep objects centered at approximately the same position in the drawing.
;; [For Mtext, that will be based on the defined Mtext box width, not the extents
;; of the content; for a Block or Text, the center of its extents in the drawing, not
;; its insertion point; for an Arc, the center of its extents, not its geometric center;
;; some entity types' (e.g. Spline's) bounding box can sometimes reach beyond
;; its extents and affect results slightly.]
;; Rejects selection of objects on locked Layers, or without a "center" [Rays, Xlines].
;; Stores scale factor; offers as default on subsequent use in same editing session.
;; Kent Cooper, 6 May 2014

(defun C:SAC (/ *error* cmde ss inc ent)
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); end if
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); end defun - *error*
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq *SACscl
(cond
( (getreal
(strcat
"\nEnter Scale Factor for blocks couning table : "
); strcat
); getreal
); User-input condition
(*SACscl); Enter on subsequent use [prior value]
(1); Enter on first use
); cond & *SACscl
ss (ssget "L" '((-4 . "")))
;; not objects on Locked Layers or without finite extents
); setq
(repeat (setq inc (sslength ss))
(setq ent (ssname ss (setq inc (1- inc))))
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
(command
".scale" ent "" "_none"
(mapcar '/ ; midpoint of bounding box
(mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt))
'(2 2 2)
); mapcar
*SACscl
); command
); repeat
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); defun
(vl-load-com)

;;; vp-outline.lsp
;;;
;;; Creates a polyline in modelspace that
;;; has the outline of the selected viewport.
;;; Supports clipped viewports. polyline is supported
;;; ellipse, spline, region and circle not supported at this point
;;; If vp-outline is called when in mspace it detects
;;; the active viewport.
;;;
;;; c:vp-outline
;;;
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2013 JTB World, All Rights Reserved
;;; Website: http://www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;; 2000-04-10
;;; 2003-11-19 Added support for drawing the outline in other ucs/view than world/current
;;;
;;; 2006-04-06 Added support for twisted views Tom Beauford
;;; 2013-06-08 Added support for circular viewports
;;;
;;; Should work on AutoCAD 2000 and newer
(vl-load-com)

(defun dxf (n ed) (cdr (assoc n ed)))

(defun ax:List->VariantArray (lst)
(vlax-Make-Variant
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbDouble
(cons 0 (- (length lst) 1))
)
lst
)
)
)

(defun c:vp-outline (/ ad ss ent pl plist xy n vpbl vpur msbl msur ven vpno ok
circ)
(setq ad (vla-get-activedocument (vlax-get-acad-object)))
(if (= (getvar "tilemode") 0)
(progn
(if (= (getvar "cvport") 1)
(progn
(if (setq ss (ssget ":E:S" '((0 . "VIEWPORT"))))
(progn (setq ent (ssname ss 0))
(setq vpno (dxf 69 (entget ent)))
(vla-Display (vlax-ename->vla-object ent) :vlax-true)
(vla-put-mspace ad :vlax-true) ; equal (command "._mspace")
; this to ensure trans later is working on correct viewport
(setvar "cvport" vpno)
; (vla-put-mspace ad :vlax-false) ; equal (command "._pspace")
(setq ok T)
(setq ss nil)
)
)
)
(setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))
ok T
)
)
(if ok
(progn (setq circle nil)
(setq ven (vlax-ename->vla-object ent))
(if (/= 1 (logand 1 (dxf 90 (entget ent)))) ; detect perspective
(progn (if (= (vla-get-clipped ven) :vlax-false)
(progn ; not clipped
(vla-getboundingbox ven 'vpbl 'vpur)
(setq vpbl (trans (vlax-safearray->list vpbl) 3 2)
msbl (trans vpbl 2 1)
msbl (trans msbl 1 0)
vpur (trans (vlax-safearray->list vpur) 3 2)
msur (trans vpur 2 1)
msur (trans msur 1 0)
vpbr (list (car vpur) (cadr vpbl) 0)
msbr (trans vpbr 2 1)
msbr (trans msbr 1 0)
vpul (list (car vpbl) (cadr vpur) 0)
msul (trans vpul 2 1)
msul (trans msul 1 0)
plist (list (car msbl)
(cadr msbl)
(car msbr)
(cadr msbr)
(car msur)
(cadr msur)
(car msul)
(cadr msul)
)
)
)
(progn ; clipped
(setq pl (entget (dxf 340 (entget ent))))
(if (= (dxf 0 pl) "CIRCLE")
(setq circle T)
(progn (setq plist (vla-get-coordinates
(vlax-ename->vla-object (dxf -1 pl))
)
plist (vlax-safearray->list (vlax-variant-value plist))
n 0
pl nil
)
(repeat (/ (length plist) 2)
(setq xy (trans (list (nth n plist) (nth (1+ n) plist)) 3 2)
xy (trans xy 2 1)
xy (trans xy 1 0)
pl (cons (car xy) pl)
pl (cons (cadr xy) pl)
n (+ n 2)
)
)
(setq plist (reverse pl))
)
)
)
)
(if circle
(vla-AddCircle
(vla-get-ModelSpace ad)
(ax:List->VariantArray
(trans (trans (trans (dxf 10 pl) 1 0) 2 1) 3 2)
)
(/ (dxf 40 pl) (caddr (trans '(0 0 1) 2 3)))
)
(vla-Put-Closed
(vla-AddLightWeightPolyline
(vla-get-ModelSpace ad)
(ax:List->VariantArray plist)
)
:vlax-True
)
)
)
)
)
)
)
)
(if ss
(vla-put-mspace ad :vlax-false)
) ; equal (command "._pspace"))
(princ)
)

(defun c:bc (/ T_OldPdmode T_Selection T_Entity T_LowerLeft T_UpperRight T_Precision T_Position T_PointList T_Count T_EntityList T_CheckLine T_IntersectPoints T_BoundaryCheck T_BlockName T_BlockList)
(if
(and
(princ "\nSelect polyline: ")
(setq T_Selection (ssget "L" '((0 . "*POLYLINE"))))
(setq T_Object (vlax-ename->vla-object (ssname T_Selection 0)))
(vlax-Curve-isClosed T_Object)
(vlax-Curve-isPlanar T_Object)
)
(progn
(setq T_Precision 0.1)
(setq T_Position 0.0)
(while
(list (list (vlax-variant-value (vla-IntersectWith (vlax-ename->vla-object T_CheckLine) T_Object acExtendNone)))))))
(= (rem (length (_GroupByNum T_IntersectPoints 3)) 2) 1)
)
(progn
(if
(not (assoc (setq T_BlockName (cdr (assoc 2 T_EntityList))) T_BlockList))
(setq T_BlockList (cons (list T_BlockName 1) T_BlockList))
(setq T_BlockList (subst (list T_BlockName (1+ (cadr (assoc T_BlockName T_BlockList)))) (assoc T_BlockName T_BlockList) T_BlockList))
)
)
(ssdel T_Entity T_Selection)
)
(if T_CheckLine (entdel T_CheckLine))
)
;(sssetfirst nil T_Selection)
(acet-ui-progress)
(princ (strcat "\n ** Total number of blocks found: " (itoa (sslength T_Selection)) "\n"))
(foreach T_Item (vl-sort T_BlockList '(lambda (T_Block1 T_Block2) (variantArray
(ptsList / arraySpace sArray)
(setq
arraySpace(vlax-make-safearray
vlax-vbdouble;elemento tipo
(cons 0(-(length ptsList)1));_ array dimension
)
)
(setq sArray(vlax-safearray-fill arraySpace ptsList))
(vlax-make-variant sArray)
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun NameUnnamedUcs
(*adoc* UcsName / *UCS* Origin XAxisPoint YAxisPoint)
(if(=(getvar"WORLDUCS")0);If UCS Difers from world then
(progn
(Setq *UCS*(vla-get-UserCoordinateSystems *adoc*)
Origin(getvar "UCSORG")
XAxisPoint(mapcar
'(lambda(pt1 pt2)(+ pt1 pt2))
Origin
(getvar "UCSXDIR")
)
YAxisPoint(mapcar
'(lambda(pt1 pt2)(+ pt1 pt2))
Origin
(getvar"UCSyDIR")
)
)
(vla-add
*Ucs*(list->variantArray Origin)
(list->variantArray XAxisPoint)
(list->variantArray YAxisPoint)
UcsName
)
)
)
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun GetBlocks (space /)
(cond
((=(Type Space)'STR)(vlax-for obj(vla-get-block(vla-item *layouts* space))(bkobj obj)))
((=(Type Space)'PICKSET)
(for-sset Space
(lambda(ename / obj)
(setq obj (vlax-ename->vla-object ename))
(bkobj obj)
)
)
)
)
BkCountLst
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun bkObj (obj / BkName)
(cond ((/= (vla-get-ObjectName obj) "AcDbBlockReference"))
((and
(setq BkName (vla-get-Name obj))
(assoc BkName BkCountLst)
)
(setq BkCountLst
(subst (cons BkName (1+ (cdr (assoc BkName BkCountLst))))
(assoc BkName BkCountLst)
BkCountLst
)
)
)
(T
(setq BkCountLst
(cons (cons BkName 1) BkCountLst)
)
)
)
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

(Defun c:BTL (/ *acad* *adoc* *Layouts* BkCountLst SpaceBkCt ptt *tabla* Table1 *BLOCKS* CTROW ROW
*TABLESTYLE* CTC COL_CT LayName NwUcs ss)
(setq *acad* (vlax-get-acad-object)
*adoc* (vla-get-activedocument *acad*)
*Layouts* (vla-get-Layouts *adoc*)
*blocks* (vla-get-Blocks *adoc*)
)
(vla-startundomark *adoc*)
(or (setq NwUcs (collection-item-p (vla-get-UserCoordinateSystems *adoc*) "BTUcs")))

(initget "Selection ModelSpace PaperSpace Total")
(setq SpaceBkCt (GetKword
"\n Press Enter to Count Blocks in this ViewPort.."
)
)
(cond ((or (= SpaceBkCt "ViewPort") (= SpaceBkCt nil))
(setq SpaceBkCt "ViewPort")
(while (null ss)
(setq ss (ssget "P" '((0 . "INSERT"))))
)
(princ "\n Getting Blocks in ViewPort...")
(GetBlocks ss)
)

((= SpaceBkCt "ModelSpace")
(setq SpaceBkCt "Model Space")
(princ "\n Getting Blocks in ModelSpace...")
(GetBlocks "Model")
)

((= SpaceBkCt "PaperSpace")
(initget "All Type Current")
(setq GetPs (GetKword
"\n Count Blocks in [/Type Name/All] layouts: "
)
)
;;; ----------
(cond ((or (= GetPs nil) (= GetPs "Current"))
(princ "\n Getting Blocks in Current Layout...")
(GetBlocks (getvar "ctab"))
(setq SpaceBkCt "Paper Space")
)
((= GetPs "All")
(princ "\n Getting Blocks in all Layouts...")
(setq Layouts (layoutlist))
(foreach lay layouts
(GetBlocks lay)
)
(setq SpaceBkCt "all Layouts")
)
(t
(while (not (member LayName (mapcar 'strcase (layoutlist))))
(setq LayName (strcase (getString "\n Type layout name: " T)))
)
(mapcar 'princ
(list "\n Getting Blocks in Layout " LayName "...")
)
(GetBlocks LayName)
(setq SpaceBkCt (strcat "Layout " LayName))
)
)
;;; ------------
)
(t
(princ "\n Getting Blocks in Paper and Model Space...")
(setq Layouts (cons "Model" (layoutlist)))
(foreach lay layouts
(GetBlocks lay)
)
)
)
(if BkCountLst
(progn
(setq BkCountLst
(vl-sort BkCountLst
(function (lambda (e1 e2)
(< (car e1) (car e2))
)
)
)
)
(princ "Done")
(cond ((collection-item-p
(vla-get-dictionaries *adoc*)
"TablaBlocks"
)
)
(T
(AddTextStyle "Anot_Arial" "ARIAL" *adoc*)
(setq *tableStyle* (vla-item (vla-get-dictionaries *adoc*)
"acad_tablestyle"
)
*tabla* (vla-addObject
*tableStyle*
"TablaBlocks"
"AcDbTableStyle"
)
)
(vla-SetTextHeight *tabla* acTitleRow 5.0);altura texto rotulo principal
(vla-SetTextHeight *tabla* acHeaderRow 3.5);altura texto rotulo bloques
(vla-SetTextHeight *tabla* acDataRow 3.5);altura texto bloques
(vla-SetTextStyle *tabla* acHeaderRow "Anot_Arial")
(vla-SetTextStyle *tabla* acTitleRow "Anot_Arial")
(vla-SetTextStyle *tabla* acDataRow "Anot_Arial")
(vla-put-Vertcellmargin *tabla* 3.5)
(vla-put-Horzcellmargin *tabla* 10.0)
)
)
(or ptt
(setq
ptt
;(trans
(getPoint
"\nSelect insertion point of Tasble: "
)
;;; 1
;;; 0
;;; )
)
)
(progn
(princ "\n Creating Table, please wait... ")
(setq Ptt (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
'(0 . 2)
)
ptt
)
)
Table1 (vla-addTable
(vla-get-ModelSpace
*adoc*
)
ptt
2
3
0.2
2.0
)
ctc 0
)
(vla-put-StyleName Table1 "TablaBlocks")
(vla-setText
Table1
0
0
(strcase (strcat "Blocks in "
(if (= SpaceBkCt "Total")
"Drawing"
SpaceBkCt
)
)
)
)
(vla-setText Table1 1 0 "Picture")
(vla-setText Table1 1 1 "Block Name")
(vla-setText Table1 1 2 "Count")
(vla-setcolumnwidth Table1 0 40.0);anchura columna bloque
(vla-setcolumnwidth Table1 1 100.0);anchura columna nombre
(vla-setcolumnwidth Table1 2 33.0);anchura columna cantidad
(vla-setRowHeight Table1 0 5)
(vla-setrowHeight Table1 1 3.5)
(if (setq NwUcs (NameUnnamedUcs *adoc* "BTUcs"))
(progn
(setq TransMatrix (vla-getUcsMatrix NwUcs))
(vla-TransformBy Table1 TransMatrix)
)
)
)

(setq row 2)
(foreach BksLst BkCountLst
(vla-insertrows Table1 row 0.35 1)
(setq Col_ct 0)
(vla-SetCellType Table1 row Col_ct acBlockCell)
(vla-SetBlockTableRecordId
Table1
row
Col_ct
(vla-get-ObjectID (vla-item *blocks* (car BksLst)))
:vlax-true
)
(setq col_ct (1+ Col_Ct)
)
(vla-SetText
Table1
(vlax-make-Variant row vlax-vbLong)
Col_ct
(vlax-Make-Variant (strcase (car BksLst)) Vlax-VbString)
)
(setq col_ct (1+ Col_Ct)
)
(vla-SetText
Table1
(vlax-make-Variant row vlax-vbLong)
Col_ct
(vlax-Make-Variant (cdr BksLst) Vlax-VbString)
)
(setq row (1+ row)
)
)
(setq ctrow 2)
(repeat (- (vla-get-rows table1) 2)
(vla-setcellalignment Table1 ctrow 1 acmiddleleft)
(setq ctrow (1+ ctrow))
)
(princ "Done")
)
(mapcar 'princ
(list "\n There are not blocks references in "
SpaceBkCt
"."
)
)
)
(vla-endundomark *adoc*)
(prin1)
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

(defun c:vbc()
(command "_.-LAYER" "_T" "0-BLOCKS-COUNTING" "_U" "0-BLOCKS-COUNTING" "_M" "0-BLOCKS-COUNTING" "_C" 1 "0-BLOCKS-COUNTING" "")
(princ "\n Select ViewPort for Blocks Counting...")
(c:vp-outline)
(c:bc)
(setvar "osmode" 0)
(c:btl)
(command "._chspace" "L" "" "")
(c:rot)
(c:sac)
(setvar "osmode" 167)
)
;(c:vbc)

Calculate horizontal & slope distance, bearing, delta X, Y & Z, percent slope between two selected points and Northing & Easting for picked points.


;;; ------------------------------------------------------------------------
;;; DistanceInquiry.lsp v2.1
;;;
;;; Copyright© 04.16.09
;;; Alan J. Thompson (alanjt)
;;;
;;; Contact: alanjt @ TheSwamp.org, CADTutor.net
;;;
;;; Permission to use, copy, modify, and distribute this software
;;; for any purpose and without fee is hereby granted, provided
;;; that the above copyright notice appears in all copies and
;;; that both that copyright notice and the limited warranty and
;;; restricted rights notice below appear in all supporting
;;; documentation.
;;;
;;; The following program(s) are provided "as is" and with all faults.
;;; Alan J. Thompson DOES NOT warrant that the operation of the program(s)
;;; will be uninterrupted and/or error free.
;;;
;;; Calculate horizontal & slope distance, bearing, delta X, Y & Z,
;;; percent slope between two selected points and Northing & Easting
;;; for picked points.
;;;
;;; The following objects may be selected for X,Y,Z:
;;; Arc, Block, Civil 3D Point, Civil 3D Surface, Circle, Ellipse,
;;; Land Desktop Point, AutoCAD Point
;;; * * If C3D surface is selected, user has option to pick point * *
;;; * * within surface and the true elevation is extracted. * *
;;;
;;; Points and bearing are translated to World UCS.
;;;
;;; * * * May be executed transparently * * *
;;;
;;; Revision History:
;;;
;;; v1.1 (04.23.09) 1. Added display of Delta X, Delta Z elevations, slope
;;; distance and Northing & Easting for picked points.
;;; 2. Added subroutines: AT:Arrow and AT:Midpoint
;;; 3. If slope between points is found, direction of
;;; flow is shown.
;;;
;;; v1.2 (04.28.09) 1. Added display of points' elevations, if applicable.
;;; 2. Updated 'AT:Arrow' subroutine.
;;; 3. Added check for elevation calculations to see if
;;; elevations for points are different.
;;;
;;; v1.3 (05.04.09) 1. Added subroutine 'AT:PointSameXY' and check to see
;;; if points are not at the same location, before
;;; calculating any slope information.
;;;
;;; v1.4 (05.12.09) 1. Added display of inquiry information with popup
;;; window, using DosLib. If user has DosLib loaded,
;;; information will display here aswell (must uncomment).
;;;
;;; v1.5 (09.23.09) 1. Added display of inches for flat distance portion. *OMITTED v1.8a*
;;;
;;; v1.6 (09.24.09) 1. Fixed issue with trying to set 'osnapz' on older versions.
;;;
;;; v1.7 (09.24.09) 1. Added display of azimuth.
;;;
;;; v1.8a(11.04.09) 1. Fixed (hopefully) coding to account for user units and luprec setttings.
;;; Added subroutine _RToS to properly set Lunits and Luprec values.
;;; 2. Added subroutine AT:DrawX and will display red "X" at first picked point.
;;; 3. Updated *error* routine.
;;; 4. Removed v1.5 update (stupid idea).
;;; 5. Added subroutines _GetPoint and AT:Entsel, now user has option to select
;;; an object in addition to picking a point.
;;; Accepted objects: C3D points, Point, Circle, Block
;;;
;;; v1.8b(11.17.09) 1. Added display of bearing in radians.
;;;
;;; v1.8c(11.18.09) 1. Added option to select arcs (will use point at radius).
;;;
;;; v1.9 (02.16.10) 1. Added Gradian display for angle between picked points.
;;;
;;; v2.0 (04.04.10) 1. Updated AT:DrawX subroutine.
;;; 2. Added option to select an Ellipse (in addition to other objects).
;;; Will use center point.
;;; 3. Fixed bug with running transparently.
;;;
;;; v2.1 (05.24.10) 1. Added option to select Civil 3D surface and extract elevation.
;;; 2. Replaced subroutine AT:Entsel with _sel. Now connecting line
;;; is drawn from first point to cursor (when in select mode).
;;; 3. When in select mode for second point, distance is dynamically
;;; displayed at the status line.
;;; 4. Fixed bug with "X" at first point not being displayed when
;;; in non-WCS.
;;; 5. Added option to select Land Desktop points.
;;;
;;; ------------------------------------------------------------------------

(defun c:D (/) (c:DistanceInquiry))
(defun c:DistanceInquiry (/ *error* AT:FlatDist AT:Arrow AT:Midpoint AT:PointSameXY AT:DrawX
_GetPoint #PromptString #AddString #OldOsnapz #Luprec #Lunits #Measure
#Arch _RToS #Point1 #Point2 #Bear #Rad #Angle #Grad #Dist #Elev #Slope
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; error handler
(defun *error* (#Message)
(and #OldOsnapz (setvar "osnapz" #OldOsnapz))
(grtext)
(and #Message
(not (wcmatch (strcase #Message) "*BREAK*,*CANCEL*,*QUIT*"))
(princ (strcat "\nError: " #Message))
) ;_ and
) ;_ defun

;;; Distance between 2 (no Z value) points
;;; Alan J. Thompson, 3.18.09
(defun AT:FlatDist (#Point1 #Point2)
(distance (list (car #Point1) (cadr #Point1))
(list (car #Point2) (cadr #Point2))
) ;_ distance
) ;_ defun

;;; Display directional arrow
;;; #Location - arrow placement point
;;; #Angle - arrow directional angle
;;; Alan J. Thompson, 04.28.09
(defun AT:Arrow (#Location #Angle / #Size #Point1 #Point2 #Point3)
(setq #Size (* (getvar "viewsize") 0.02)
#Point1 (polar #Location #Angle #Size)
#Point2 (polar #Location (+ #Angle (* pi 0.85)) #Size)
#Point3 (polar #Location (+ #Angle (* pi 1.15)) #Size)
) ;_ setq
(grvecs
(list 4 #Point1 #Point2 #Point2 #Point3 #Point3 #Point1)
) ;_ grvecs
) ;_ defun

;;; Midpoint between two points
;;; Alan J. Thompson, 04.23.09
(defun AT:Midpoint (#Point1 #Point2)
(mapcar '(lambda (x y)
(/ (+ x y) 2.0)
) ;_ lambda
#Point1
#Point2
) ;_ mapcar
) ;_ defun

;;;Check if two points are same X & Y (Z ignored)
;;;Return: T if same, nil if different
;;;Alan J. Thompson, 05.04.09
(defun AT:PointSameXY (#Point1 #Point2)
(equal (list (car #Point1) (cadr #Point1))
(list (car #Point2) (cadr #Point2))
0.00001
) ;_ equal
) ;_ defun

;;; Draw and "X" vector at specified point
;;; P - Placement point for "X"
;;; C - Color of "X" (must be integer b/w 1 & 255)
;;; Alan J. Thompson, 10.31.09
(defun AT:DrawX (P C / d n)
(if (and (vl-consp P)
(setq d (* (getvar "VIEWSIZE") 0.02))
) ;_ and
(progn (grvecs (cons C
(mapcar
(function (lambda (#) (polar P (* # pi) d)))
'(0.25 1.25 0.75 1.75)
) ;_ mapcar
) ;_ cons
) ;_ grvecs
P
) ;_ progn
) ;_ if
) ;_ defun

(defun _sel (pnt msg flt / gr e)
(while (and (setq gr (grread T 15 2))
(/= (car gr) 25)
(not (vl-position (cadr gr) '(13 158)))
(not e)
)
(redraw)
(and pnt (grtext -1 (rtos (distance pnt (cadr gr)))) (grdraw (AT:DrawX pnt 1) (cadr gr) 3 -1))
(princ (strcat "\r" msg))
(if (and (eq 3 (car gr))
(setq e (ssget (cadr gr)))
(wcmatch (cdr (assoc 0 (entget (setq e (ssname e 0))))) flt)
)
(setq e (vlax-ename->vla-object e))
(setq e nil)
)
)
(redraw)
(grtext)
e
)

(defun _GetPoint (#Point #Msg / _Get _ToList #Pnt #NoTrans #Obj #Value #N #E #Z sur pnt elev)
(setq _Get
(lambda (o p / c)
(if
(not (vl-catch-all-error-p (setq c (vl-catch-all-apply 'vlax-get-property (list o p))))
) ;_ not
c
) ;_ if
) ;_ lambda
) ;_ setq
(setq _ToList (lambda (v)
(if v
(vlax-safearray->list (vlax-variant-value v))
) ;_ if
) ;_ lambda
) ;_ setq
(initget 0 "Select sUrface")
(and
(if #Point
(setq #Pnt (getpoint #Point #Msg))
(setq #Pnt (getpoint #Msg))
) ;_ if
(cond
;; selected point
((vl-consp #Pnt)
(setq #Value #Pnt
#NoTrans T
) ;_ setq
)
;; sUrface
((eq "sUrface" #Pnt)
(if
(and
(setq *DI:Surface*
(cond (
;;; (AT:Entsel nil
;;; (strcat "\nSelect Civil 3D surface"
;;; (if *DI:Surface*
;;; " : "
;;; ": "
;;; )
;;; )
;;; '("V" (0 . "AECC_TIN_SURFACE"))
;;; nil
;;; )
(_sel #Point
(strcat "Select Civil 3D surface"
(if *DI:Surface*
(strcat " : "
)
": "
)
)
"AECC_TIN_SURFACE"
)

)
(*DI:Surface*)
)
)
(while (not elev)
(and
(setq pnt (if #Point
(getpoint #Point "\nSpecify point within C3D surface: ")
(getpoint "\nSpecify point within C3D surface: ")
)
)
(setq pnt (trans pnt 1 0))
(or
(> (setq elev (vlax-invoke *DI:Surface* 'FindElevationAtXY (car pnt) (cadr pnt)))
-99999.9
)
(setq elev (prompt "\nPoint outside of surface!"))
)
)
)
)
(setq #Value (list (car pnt) (cadr pnt) elev))
)
)
;; "Select" chosen
((eq "Select" #Pnt)
;;; (princ "\nAcceptable objects: ARC AECC_COGO_POINT CIRCLE ELLIPSE INSERT POINT")
(and
(setq #Obj
(_sel #Point
"Select object: "
"AECC_COGO_POINT,AECC_POINT,ARC,CIRCLE,ELLIPSE,INSERT,POINT"
)
)

;;; (setq
;;; #Obj (AT:Entsel nil
;;; nil
;;; '("V" (0 . "AECC_COGO_POINT,ARC,CIRCLE,ELLIPSE,INSERT,POINT"))
;;; nil
;;; ) ;_ AT:Entsel
;;; ) ;_ setq
(cond
;; aecc_cogo_point (civil 3d)
((eq "AeccDbCogoPoint" (_Get #Obj 'ObjectName))
(and (setq #E (_Get #Obj 'Easting))
(setq #N (_Get #Obj 'Northing))
(setq #Z (_Get #Obj 'Elevation))
(setq #Value (list #E #N #Z))
) ;_ and
)
;;AECC_POINT (land desktop)
((eq "AeccDbPoint" (_Get #Obj 'ObjectName))
(setq #Value (cdr (assoc 11 (entget (vlax-vla-object->ename #Obj)))))
)
;; circle
((vl-position (_Get #Obj 'ObjectName) '("AcDbArc" "AcDbCircle" "AcDbEllipse"))
(setq #Value (_ToList (_Get #Obj 'Center)))
)
;; insert
((eq "AcDbBlockReference" (_Get #Obj 'ObjectName))
(setq #Value (_ToList (_Get #Obj 'InsertionPoint)))
)
;; point
((eq "AcDbPoint" (_Get #Obj 'ObjectName))
(setq #Value (_ToList (_Get #Obj 'Coordinates)))
)
(T (setq #Value nil))
) ;_ cond
) ;_ and
)
) ;_ cond
) ;_ and
(cond
((and #Value #NoTrans) #Value)
((and #Value (not #NoTrans)) (trans #Value 0 1))
(T #Value)
) ;_ cond
) ;_ defun

;; custom rtos
(setq _RToS (lambda (x) (rtos x #Lunits #Luprec)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(vl-load-com)

;; remove any existing arrows & set prompt string
(cond ((eq 1 (getvar 'cmdactive)) (setq #AddString "\n"))
(t (setq #AddString "") (vl-cmdf))
) ;_ cond
(redraw)
(setq #PromptString "\n-------------------------------------------------------")

;; fix osnapz to take actual elevation of points
(and (setq #OldOsnapz (getvar "osnapz")) (setvar "osnapz" 0))

;; retrieve LUPREC, LUNITS & MEASUREMENT settings
(setq #Luprec (getvar "luprec")
#Lunits (getvar "lunits")
#Measure (getvar "measurement")
) ;_ setq

;; account for architectural units (multiply by 12)
(if (and (eq 4 #Lunits) (zerop #Measure))
(setq #Arch 12)
(setq #Arch 1)
) ;_ if

(cond
((and (AT:DrawX (setq #Point1 (_GetPoint nil "\nSpecify first point [Select/sUrface]: ")) 1)
(setq #Point2 (_GetPoint #Point1 "\nSpecify next point [Select/sUrface]: "))
) ;_ and
;; clear "X"
(redraw)
;; points picked, calculation time
(setq #Point1 (trans #Point1 1 0)
#Point2 (trans #Point2 1 0)
#Rad (angle #Point1 #Point2)
#Bear (angtos #Rad 4 4)
#Angle (angtos #Rad 1 4)
#Grad (angtos #Rad 2)
#Dist (* #Arch (AT:FlatDist #Point1 #Point2))
) ;_ setq
;; calc & display Delta X, Y, Z
(setq #PromptString
(strcat #PromptString
"\nDelta X: "
(_RToS (- (car #Point2) (car #Point1)))
", Delta Y: "
(_RToS (- (cadr #Point2) (cadr #Point1)))
", Delta Z: "
(_RToS (- (caddr #Point2) (caddr #Point1)))
) ;_ strcat
) ;_ setq
;; display northing & easting for picked points
(setq #PromptString
(strcat #PromptString
"\nFrom: N="
(_RToS (cadr #Point1))
", E="
(_RToS (car #Point1))
" -> To: N="
(_RToS (cadr #Point2))
", E="
(_RToS (car #Point2))
) ;_ strcat
) ;_ setq
;; if points have elevation, % slope & slope distance calced, direction & point elevations displayed
(cond
((and (or (> (caddr #Point1) 0.)
(> (caddr #Point2) 0.)
) ;_ or
(not (AT:PointSameXY #Point1 #Point2))
(not (eq (caddr #Point1) (caddr #Point2)))
) ;_ and
(setq #Elev (- (caddr #Point2)
(caddr #Point1)
) ;_ -
#Slope (* 100. (/ #Elev #Dist))
) ;_ setq
(setq #PromptString
(strcat #PromptString
"\nSlope Distance: "
(_RToS (* #Arch (distance #Point1 #Point2)))
", Slope: "
(_RToS #Slope)
"% [From: "
(_RToS (caddr #Point1))
" -> To: "
(_RToS (caddr #Point2))
"]"
) ;_ strcat
) ;_ setq
;; draw directional arrow at midpoint between picked points
(AT:Arrow (trans (AT:Midpoint #Point1 #Point2) 0 1)
(if (> (caddr #Point1) (caddr #Point2))
(angle (trans #Point1 0 1) (trans #Point2 0 1))
(angle (trans #Point2 0 1) (trans #Point1 0 1))
) ;_ if
) ;_ AT:Arrow
)
) ;_ cond
;; bearing & distance b/w points
(setq #PromptString
(strcat #PromptString
"\nRad: "
(_RTos #Rad)
", Azm: "
#Angle
", Grad: "
#Grad
", Bear: "
#Bear
", Dist: "
(_RToS #Dist)
(if (and (< #Dist 6.1) (eq (strcase (getvar 'loginname)) "ATHOMPSON"))
(strcat " [" (_RToS (* #Dist 12.)) "in]")
""
) ;_ if
#AddString
) ;_ strcat
) ;_ setq
;; print everything to commandline & user dos_lib if applicable
(prompt #PromptString)

;;(and dos_traywnd (dos_traywnd "Distance Inquiry" #PromptString 360 100 "" 1500))

)
) ;_ cond
;; reset everything
(*error* nil)
(princ)
) ;_ defun

Area Report from 2 Numeric Texts or 2 Linear Dimensions or 2 Numeric Block Attributes as txt file with text string in format A x B .. = Area (cm²)


;; Area Report from 2 Numeric Texts or 2 Linear Dimensions or 2 Numeric Block Attributes as txt file with text string in format A x B .. = Area (cm²)
;; Created by Dlanor 2018 (thanks to Tim Willey) slightly modified by Igal Averbuh 2018 (add changed to multiply)
;; Saved from: http://www.theswamp.org/index.php?topic=54104.0

;; PLEASE READ FIRST
;; Error checking is basic. The Sub (rh:get_num) only checks if the string is empty having removed all digits
;; the decimal point and any spaces. This is the minimum to allow atof. Integers will be parsed to reals
;;
;; You can select Dimensions, Attributes or Text provided the selected item ONLY contains Numbers.
;; MText may fail due to the formatting contained within the text string.
;; An allowance has been made for spaces. Text containing spaces should parse.
;; Select entities individually. If an object is not allowed and alert box will inform you why
;; but you can continue to select. To end the entity selection left click on an empty area of the screen
;; This will produce an empty entity selection and exit the selection loop.
;; Be aware discrepancies may arise due to rounding required.
;; If you need to alter the number accuracy or Report file name please change
;; the first or second line in the first setq statement as required
;; I've included a "shortcut" to start the lisp (defun c:ax() (c:addtxts)). If you change the main routine name
;; you will need to update the "shortcut" as well
;; so type "addtxts" or "ax" to start
;;
(vl-load-com)

(defun rh:get_num ( txt )
(if (= (vl-string-trim ".0123456789 " txt) "")
(setq txt (atof txt))
(setq txt '())
);end_if
);end_defun

(defun c:ax () (c:addtxts))

(defun c:addtxts ( / *error* ent e_len obj txt_num t_lst xport_str file_name f_ptr m_txt o_lst)

(defun *error* ( msg )
(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occurred.")))
(princ)
);_end_*error*_defun

(setq acc 1 ;<<==== Alter this to change the number of decimal places for the report
file_name (strcat (getvar "dwgprefix") "Area Export Report.txt") ;vla-object ent))
(cond ( (or (= (vla-get-objectname obj) "AcDbAlignedDimension") ;Aligned Dims
(= (vla-get-objectname obj) "AcDbRotatedDimension") ;Linear Dims
(= (vla-get-objectname obj) "AcDbArcDimension") ;ArcLength Dims
);end_or
(if (/= (vla-get-textoverride obj) "")
(setq txt_num (rh:get_num (vla-get-textoverride obj)))
(setq txt_num (vla-get-measurement obj))
);end_if
(setq m_txt "Overridden Dimension Text")
);end_cond1
( (or (= (vla-get-objectname obj) "AcDbText") (= (vla-get-objectname obj) "AcDbAttribute"))
(setq txt_num (rh:get_num (vla-get-textstring obj))
m_txt (if (= (vla-get-objectname obj) "AcDbAttribute")
"Attribute"
"Text"
);end_if
);end_setq
);end_cond2
(t
(alert "Not an Allowed Dimension, Text or Attribute")
(setq ent nil)
);end_cond3
);end_cond

(if (numberp txt_num)
(progn
(redraw ent 3)
(setq t_lst (cons txt_num t_lst)
o_lst (cons ent o_lst)
);end_setq
(if (= (strlen xport_str) 0)
(setq xport_str (strcat xport_str (rtos txt_num 2 acc)))
(setq xport_str (strcat xport_str " x " (rtos txt_num 2 acc)))
);end_if
);end_progn
(if ent (alert (strcat "Selected " m_txt " is NOT a number")))
);end_if
);end_progn
);end_if
);end_while
(if (> (length t_lst) 0)
(progn
(setq xport_str (strcat xport_str " = " (rtos (apply '* t_lst) 2 acc) " cm²")
f_ptr (open file_name "a")
);end_setq
(write-line " " f_ptr)
(write-line "Area =" f_ptr)
(princ xport_str f_ptr)
(close f_ptr)
(startapp "notepad.exe" file_name)
);end_progn
);end_if
(mapcar '(lambda (x) (redraw x 4)) o_lst)
(princ)
);end_defun
(princ)
(c:ax)

Area Report from 2 Numeric Texts or 2 Linear Dimensions or 2 Numeric Block Attributes as txt file with text string in format A x B .. = Area (m²)


;; Area Report from 2 Numeric Texts or 2 Linear Dimensions or 2 Numeric Block Attributes as txt file with text string in format A x B .. = Area (m²)
;; Created by Dlanor 2018 (thanks to Tim Willey) slightly modified by Igal Averbuh 2018 (add changed to multiply)
;; Saved from: http://www.theswamp.org/index.php?topic=54104.0

;; PLEASE READ FIRST
;; Error checking is basic. The Sub (rh:get_num) only checks if the string is empty having removed all digits
;; the decimal point and any spaces. This is the minimum to allow atof. Integers will be parsed to reals
;;
;; You can select Dimensions, Attributes or Text provided the selected item ONLY contains Numbers.
;; MText may fail due to the formatting contained within the text string.
;; An allowance has been made for spaces. Text containing spaces should parse.
;; Select entities individually. If an object is not allowed and alert box will inform you why
;; but you can continue to select. To end the entity selection left click on an empty area of the screen
;; This will produce an empty entity selection and exit the selection loop.
;; Be aware discrepancies may arise due to rounding required.
;; If you need to alter the number accuracy or Report file name please change
;; the first or second line in the first setq statement as required
;; I've included a "shortcut" to start the lisp (defun c:ax() (c:addtxts)). If you change the main routine name
;; you will need to update the "shortcut" as well
;; so type "addtxts" or "ax" to start
;;
(vl-load-com)

(defun rh:get_num ( txt )
(if (= (vl-string-trim ".0123456789 " txt) "")
(setq txt (atof txt))
(setq txt '())
);end_if
);end_defun

(defun c:ax () (c:addtxts))

(defun c:addtxts ( / *error* ent e_len obj txt_num t_lst xport_str file_name f_ptr m_txt o_lst)

(defun *error* ( msg )
(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nAn Error : " msg " occurred.")))
(princ)
);_end_*error*_defun

(setq acc 1 ;<<==== Alter this to change the number of decimal places for the report
file_name (strcat (getvar "dwgprefix") "Area Export Report.txt") ;vla-object ent))
(cond ( (or (= (vla-get-objectname obj) "AcDbAlignedDimension") ;Aligned Dims
(= (vla-get-objectname obj) "AcDbRotatedDimension") ;Linear Dims
(= (vla-get-objectname obj) "AcDbArcDimension") ;ArcLength Dims
);end_or
(if (/= (vla-get-textoverride obj) "")
(setq txt_num (rh:get_num (vla-get-textoverride obj)))
(setq txt_num (vla-get-measurement obj))
);end_if
(setq m_txt "Overridden Dimension Text")
);end_cond1
( (or (= (vla-get-objectname obj) "AcDbText") (= (vla-get-objectname obj) "AcDbAttribute"))
(setq txt_num (rh:get_num (vla-get-textstring obj))
m_txt (if (= (vla-get-objectname obj) "AcDbAttribute")
"Attribute"
"Text"
);end_if
);end_setq
);end_cond2
(t
(alert "Not an Allowed Dimension, Text or Attribute")
(setq ent nil)
);end_cond3
);end_cond

(if (numberp txt_num)
(progn
(redraw ent 3)
(setq t_lst (cons txt_num t_lst)
o_lst (cons ent o_lst)
);end_setq
(if (= (strlen xport_str) 0)
(setq xport_str (strcat xport_str (rtos txt_num 2 acc)))
(setq xport_str (strcat xport_str " x " (rtos txt_num 2 acc)))
);end_if
);end_progn
(if ent (alert (strcat "Selected " m_txt " is NOT a number")))
);end_if
);end_progn
);end_if
);end_while
(if (> (length t_lst) 0)
(progn
(setq xport_str (strcat xport_str " = " (rtos (apply '* t_lst) 2 acc) " m²")
f_ptr (open file_name "a")
);end_setq
(write-line " " f_ptr)
(write-line "Area =" f_ptr)
(princ xport_str f_ptr)
(close f_ptr)
(startapp "notepad.exe" file_name)
);end_progn
);end_if
(mapcar '(lambda (x) (redraw x 4)) o_lst)
(princ)
);end_defun
(princ)
(c:ax)

Numeric Texts Sum Report as txt file with text string in format A+B+C+.. = Sum


; Numeric Texts Sum Report as txt file with text string in format A+B+C+.. = Sum
; Created by Dlanor 2018
; Based on mfuccaro@hotmail.com routine with Enhancements by CAD Studio, 2012 and Tharwat routine
; Saved from: http://www.theswamp.org/index.php?topic=54104.0

(defun C:tax (/ c_doc ent ss t_lst xport_str fn file)
(prompt "\nSelect 2 M. Numeric Texts to Multiple : ")
(setq c_doc (vla-get-activedocument (vlax-get-acad-object))
ent (ssget '((0 . "TEXT")))
ss (vla-get-activeselectionset c_doc)
xport_str ""
)
(vlax-for obj ss
(setq t_lst (cons (atof (vla-get-textstring obj)) t_lst))
(if (= (strlen xport_str) 0)
(setq xport_str (strcat xport_str (vla-get-textstring obj)))
(setq xport_str (strcat xport_str " * " (vla-get-textstring obj)))
)
)
(setq xport_str (strcat xport_str " = " (rtos (apply '* t_lst) 2 2))
ss nil
fn (strcat (getvar "dwgprefix") "Export Report.txt")
file (open fn "a") ; append
)
(write-line "" file)
(princ (strcat "\nAreas written to:" fn))
(write-line "Area =" file)
(princ xport_str file)
(write-line " m²" file)
(close file)
(startapp "notepad.exe" fn)
)
(c:tax)

Kent Cooper’s put Text indicating LENGTH(s) of selected object(s) at MIDPOINT(s) of these objects


;| LengthAtMidPoints.lsp [command name: LMP]
To put Text indicating LENGTH(s) of selected object(s) at MIDPOINT(s).
Draws Text in current Style and on current Layer.
Works with objects in any Coordinate System.
Kent Cooper, 27 February 2018
|;
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/line-length-typing-lisp/td-p/2119240
;;; Slightly Modified by Igal Averbuh 2018 (added option to set text height, also by 2 points on screen + creating new text style and new layer with ID data)

;UCS and Layer State with date,time stamp and user name. Upgrated by Igal Averbuh 2015

(defun C:ldate (/ ss1 count emax en ed blkn found
thedate thetime plotby)
;define function and declare variables as local

(setvar "HIGHLIGHT" 0)
;switch off highlight

(setvar "CMDECHO" 0)
;switch off command echo

(setq ss1 (ssget "X" '((0 . "INSERT")(66 . 1))))
;filter for all blocks with attributes

(if ss1
;if any are found

(progn
;do the following

(setq count 0
;set the counter to zero

emax (sslength ss1)
;get the number of blocks

);setq

(while (< count emax)
;while the counter is less than the
;number of blocks

(setq en (ssname ss1 count)
;get the entity name

ed (entget en)
;get the entity list

blkn (dxf 2 ed)
;get the block name

);setq

(if (= "STAMP")
;if the block name is "STAMP"

(setq count emax
;stop the loop

found T
;set the flag

);setq

(setq count (1+ count))
;if not increment the counter

);end if

);while & if

(if found
;if the flag is set

()
;erase the block

);if

);progn

);if

(setvar "ATTDIA" 0)
;switch off dialogue boxes

(setq thedate (today))
;calculate and format date

(setq thetime (time))
;calculate and format time

(setq plotby (getvar "LOGINNAME"))
;get the users name

(setq by (strcat "0Length Calculated by " plotby " " thedate " " thetime ))

(command "-layer" "n" by "")
(command "-layer" "s" by "")

()
;insert the block and fill in the attribute data

(setvar "ATTDIA" 1)
;switch the dialogues back on

(setvar "HIGHLIGHT" 1)
;switch Highlight On

(setvar "CMDECHO" 1)
;switch Cmdecho On

(princ)

);defun

;===============================================================
(defun dxf(code elist)

(cdr (assoc code elist))
;finds the association pair, strips 1st element

);defun
;===============================================================
(defun TODAY ( / d yr mo day)
(setq d (rtos (getvar "CDATE") 2 6)
yr (substr d 3 2)
mo (substr d 5 2)
day (substr d 7 2)
);setq
(strcat day "-" mo "-" yr)
);defun
;;;*-----------------------------------------------------------
(defun TIME ( / d hr m s)
(setq d (rtos (getvar "CDATE") 2 6)
hr (substr d 10 2)
m (substr d 12 2)
s (substr d 14 2)
);setq
(strcat hr "-" m "-" s)
);defun
;;;*------------------------------------------------------------
(princ)

(c:ldate)

(defun c:kent () ;; Create text style arial.ttf
(command "-style" "kent" "arial.ttf" "" "" "0" "" "")
)

(c:kent)

(vl-load-com)

(defun C:LMP ; = Length at Mid-Point
(/ *error* lmp-reset LMPss doc svnames svvals n path pathdata pathtype pathextr ucschanged lmp-pt len)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); if
(if ucschanged (command "_.ucs" "_prev"))
;; ^ don't go back unless routine reached UCS change but didn't change it back
(vla-endundomark doc)
(lmp-reset)
); defun - *error*

(defun lmp-reset ()
(mapcar 'setvar svnames svvals); reset
(princ)
); defun - lmp-reset

(setvar 'textsize
(cond ((getdist (strcat "\nSpecify Text Height: : ")))
((getvar 'textsize))
)
)

(prompt "\nTo mark Length(s) at object Midpoint(s),")
(if
(setq LMPss (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))))
(progn ; then
(vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
(setq
svnames '(osmode blipmode cmdecho)
svvals (mapcar 'getvar svnames)
); setq
(setvar 'cmdecho 0)
(repeat (setq n (sslength LMPss))
(setq
path (ssname LMPss (setq n (1- n)))
pathdata (entget path)
pathtype (cdr (assoc 0 pathdata))
pathtype
(if (wcmatch pathtype "POLYLINE")
(strcase (substr (cdr (assoc 100 (reverse pathdata))) 5)); then
;; ^ = entity type from second (assoc 100) without "AcDb" prefix; uses this because (assoc 0)
;; value is the same for 2D heavy & 3D Polylines; can set UCS to match former, but not latter
pathtype ; else - leave alone
); if and pathtype
pathextr (cdr (assoc 210 pathdata))
); setq
(if ; set UCS to match object only under certain circumstances
(or ; look at entity types other than 3D Polylines and 3D Splines
(and
(= pathtype "LINE")
(not ; unequal Z components at ends, in current CS
(equal
(caddr (trans (cdr (assoc 10 pathdata)) 0 1))
(caddr (trans (cdr (assoc 11 pathdata)) 0 1))
1e-12
); equal
); not
); and - Line UCS check
(and
(wcmatch pathtype "ARC,CIRCLE,ELLIPSE,LWPOLYLINE,2DPOLYLINE")
(not (equal (trans pathextr 0 1) '(0 0 1) 1e-6)); extrusion direction not = current CS
); and - A/C/E/LWP/2dP UCS check
(and
(= pathtype "SPLINE")
(if pathextr (not (equal (trans pathextr 0 1) '(0 0 1) 1e-12)))
;; ^ planar [2D] Splines have 210 value; non-planar [3D] do not
); and - Spline UCS check
); or - need to change UCS
(progn
(if (equal pathextr '(0 0 1) 1e-12)
(command "_.ucs" "_world"); then
(if (= pathtype "LINE") ; outer else -- set UCS to match object
(command "_.ucs" (vlax-curve-getStartPoint path) (vlax-curve-getEndPoint path) "")
; then -- sometimes UCS OB on Line does it with Line up Z axis
(command "_.ucs" "_new" "_object" path); else [other entity types]
); if
); if
(setq ucschanged T) ; marker for *error* to reset UCS if routine doesn't get to it
); progn
); if - UCS match object
(mapcar 'setvar svnames '(0 0)); Osnap and blips off
(command
"_.text" "_justify" "_bc"
(trans
(setq lmp-pt ; insertion point
(vlax-curve-getPointAtDist ; midway along length
path
(/
(setq len (vlax-curve-getDistAtParam path (vlax-curve-getEndParam path))); overall length
2
); /
); getPointAtDist
); setq
0 1 ; WCS to current CS
)
); command ; leave in Text command
(if (member '(40 . 0.0) (entget (tblobjname "style" (getvar 'textstyle)))) (command ""))
; accept current-height default if non-fixed-height or non-annotative Style
(command ; continue
(angtos ; rotation -- local direction of path
(+
(angle
'(0 0 0)
(trans
(vlax-curve-getFirstDeriv
path
(vlax-curve-getParamAtPoint path lmp-pt)
); getFirstDeriv
0 1 T; WCS to current CS, as displacement
); trans
); angle
(if ; put text on outboard side of Arc/Circle/Ellipse/LWPline arc segment
(or
(wcmatch pathtype "ARC,CIRCLE,ELLIPSE")
(and
(= pathtype "LWPOLYLINE") ;;;;; what about "heavy" Polyline arc segment?
(> ; midway point on arc segment with CCW curvature?
(vla-getBulge (vlax-ename->vla-object path) (vlax-curve-getParamAtPoint path lmp-pt))
0.0
); >
); and
); or
pi 0 ; then = spin around, else = direction unaltered
); if
); +
(getvar 'aunits) 8
); angtos
(rtos len 2 1); text content
); command
(if ucschanged (progn (command "_.ucs" "_prev") (setq ucschanged nil)))
; eliminate UCS reset in *error* since routine did it already
); repeat
(lmp-reset)
(vla-endundomark doc)
); progn
); if
); defun - LMP

(prompt "Type LMP to mark the Lengths of selected objects at their Mid-Points.")
(c:lmp)

Count selected objects length by layer and put it in table form into a drawing


;Count selected objects length by layer and put it in table form into a drawing
;Stefan M. 22.09.2016
(defun C:LAY ( / *error* acdoc ss p i e a d l s h dz) (vl-load-com)
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
dz (getvar 'dimzin))
(vla-startundomark acdoc)
(setvar 'dimzin 1)

(defun *error* (msg)
(and
msg
(not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(setvar 'dimzin dz)
(if
(= 8 (logand (getvar 'undoctl) 8))
(vla-endundomark acdoc)
)
(princ)
)

(if
(and
(setq ss (ssget ":L" '((0 . "LINE,POLYLINE,LWPOLYLINE,ARC,CIRCLE,ELLIPSE,SPLINE,HATCH"))))
(setq p (getpoint "\nTable scale depend on annotation scale.\nSpecify table insert point: "))
)
(progn
(repeat
(setq i (sslength ss))
(setq e (vlax-ename->vla-object (ssname ss (setq i (1- i))))
a (vla-get-layer e)
)
(if
(setq h (eq (vla-get-objectname e) "AcDbHatch"))
(setq s (vla-get-area e))
(setq d (vlax-curve-getdistatparam e (vlax-curve-getendparam e)))
)
(if
(setq o (assoc a l))
(if h
(setq l (subst (list a (cadr o) (+ (caddr o) s)) o l))
(setq l (subst (list a (+ (cadr o) d) (caddr o)) o l))
)
(if h
(setq l (cons (list a 0.0 s) l))
(setq l (cons (list a d 0.0) l))
)
)
)
(setq l (vl-sort l '(lambda (a b) (< (car a) (car b)))))
(insert_table l p)
)
)
(*error* nil)
(princ)
)

(defun insert_table (lst pct / tab row col ht i n space )
(setq space (vlax-get acDoc (if (= 1 (getvar 'cvport)) 'PaperSpace 'ModelSpace))
ht (/ 2.5 (cond ((getvar 'cannoscalevalue)) (1.0)))
pct (trans pct 1 0)
n (trans '(1 0 0) 1 0 T)
tab (setq tab (vla-addtable space (vlax-3d-point pct) (+ 2 (length lst)) (length (car lst)) (* 2.5 ht) ht))
)
(vlax-put tab 'direction n)

(mapcar
(function
(lambda (rowType)
(vla-SetTextStyle tab rowType (getvar 'textstyle))
(vla-SetTextHeight tab rowType ht)
)
)
'(2 4 1)
)

(vla-put-HorzCellMargin tab (* 0.14 ht))
(vla-put-VertCellMargin tab (* 0.14 ht))

(setq lst (cons '("Layer" "Length") lst))

(setq i 0)
(foreach col (apply 'mapcar (cons 'list lst))
(vla-SetColumnWidth tab i
(apply
'max
(mapcar
'(lambda (x)
((lambda (txb) (+ (abs (- (caadr txb) (caar txb))) (* 2.0 ht)))
(textbox
(list
(cons 1
(cond
((eq (type x) 'STR) x)
((eq (type x) 'INT) (itoa x))
((eq (type x) 'REAL) (rtos x))
)
)
(cons 7 (getvar 'textstyle))
(cons 40 ht))
)
)
)
col
)
)
)
(setq i (1+ i))
)

(setq lst (cons '("TITLE") lst))

(setq row 0)
(foreach r lst
(setq col 0)
(foreach c r
(if
(not (eq c 0))
(progn
(vla-SetText tab row col c)
(vla-SetCellDataType
tab row col
(cdr (assoc (type c) '((STR . 4) (REAL . 2) (INT . 1))))
acUnitless
)
(vla-setCellAlignment tab row col acMiddleCenter)
)
)
(setq col (1+ col))
)
(vla-SetRowHeight tab row (* 1.6 ht))
(setq row (1+ row))
)
)
(c:lay)

Draw Length of multi Lines, Arcs, Circles and Ellipses as Masked Mtext


;;; Draw length of multi Lines, Arcs, Circles and Ellipses as Masked Mtext
;;; Saved from here: http://www.cadtutor.net/forum/showthread.php?56656-Lisp-help-Selecting-multi-lines-and-labeling-them/page2

(defun c:lm(/ aDoc cTxt eLen ePar iAng iDr lPnt lSet oldSize sPar tWid lCol
cLay nTxt Precision Suffix BackMask Layer Color)

; *****************************************************************************
; ADJUSTMENTS ;
; (Modify it to adjust for your own requirements) ;
; *****************************************************************************

(setq Precision 1) ; - precision of measurement (digits after decimal point)

(setq Suffix "m") ; - Suffix after measirement for ex. "'" or "" for none

(setq BackMask 1.0) ; - Background mask borders from 1.0 to 10.0
; or nil for none. Reocomended value 1.0.
; !!! nil for versions ealer AutoCAD 2005 !!!

(setq Layer "0-Length-Calculation") ; - layer of markers or nil for current layer

(setq Color 1) ; - color of layer for ex. 1 (Red)

; ******************************* END ADJUSTMENTS *****************************

(vl-load-com)

(defun Add_Masked_MText(Str Pt Hei Wid wiF Ang Mask
/ oOsn cLay cTxt actSp nTxt
oDxf nDxf mPt xPt aDoc aSp lFlg)

; (Add_Masked_MText )

(setq oOsn(getvar "OSMODE")
aDoc(vla-get-ActiveDocument
(vlax-get-acad-object))
cLay (vla-get-ActiveLayer aDoc)
aSp(vla-get-ActiveSpace aDoc)
); end setq
(if(= 1 aSp)
(setq aSp(vla-get-ModelSpace aDoc))
(setq aSp(vla-get-PaperSpace aDoc))
); end if
(if(= :vlax-true(vla-get-Lock cLay))
(progn
(vla-put-Lock cLay :vlax-false)
(setq lFlg T)
); end progn
); end if
(if(= 1.0 wiF)
(setq cTxt(strcat "\\pxqc;" Str))
(setq cTxt(strcat "\\pxqc;{\\W" (rtos wiF) ";" Str "}"))
); end if
(setq nTxt(vla-AddMText aSp
(vlax-3D-point '(0.0 0.0 0.0)) 1.0 cTxt))
(vla-put-Height nTxt Hei)
(vla-put-Width nTxt(+ Wid(/ Hei 2)))
(if Mask
(progn
(vla-put-BackgroundFill nTxt -1)
(setq oDxf(entget(vlax-vla-object->ename nTxt))
nDxf(subst (cons 45 Mask)(assoc 45 oDxf)oDxf)
); end setq
(entmod nDxf)
); end progn
); end if
(vla-getBoundingBox nTxt 'mPt 'xPt)
(setq mPt(vlax-safearray->list mPt)
xPt(vlax-safearray->list xPt)
mPt(vlax-3d-point
(list(+(car mPt)(/(-(car xPt)(car mPt))2))
(+(cadr mPt)(/(-(cadr xPt)(cadr mPt))2))
0.0))
); end setq
(vla-Move nTxt mPt(vlax-3D-point Pt))
(if(and(> Ang 0)(<= Ang pi))
(vla-Rotate nTxt(vlax-3D-point Pt)(- Ang(/ pi 2)))
(vla-Rotate nTxt(vlax-3D-point Pt)(+ Ang(/ pi 2)))
); end if
(if lFlg
(vla-put-Lock cLay :vlax-true)
); end if
nTxt
); end of Add_Masked_MText

(if(not lab:Size)(setq lab:Size(getvar "TEXTSIZE")))
(setq oldSize lab:Size
lab:Size
(getreal
(strcat "\nText size : ")))
(if(null lab:Size)(setq lab:Size oldSize))
(princ "\n<<>> ")
(if(setq lSet(ssget '((0 . "*LINE,ARC,ELLIPSE,CIRCLE"))))
(progn
(setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object))
lCol(vla-get-Layers aDoc)
); end setq
(vla-StartUndoMark aDoc)
(if Layer
(if(vl-catch-all-error-p
(vl-catch-all-apply
'vla-Item(list lCol Layer)))
(progn
(setq cLay(vla-Add lCol Layer))
(vla-put-Color cLay Color)
); end progn
); end if
); end if
(foreach l(vl-remove-if 'listp(mapcar 'cadr(ssnamex lSet)))
(setq sPar(vlax-curve-getStartParam l)
ePar(vlax-curve-getEndParam l)
eLen(-(vlax-curve-getDistAtParam l ePar)
(vlax-curve-getDistAtParam l sPar))
lPnt(vlax-curve-getPointAtDist l(/ eLen 2))
iDr(vlax-curve-getFirstDeriv l
(vlax-curve-getParamAtPoint l lPnt))
iAng(- pi
(atan
(/(car iDr)
(if(= 0.0(cadr iDr))(* 2 pi)(cadr iDr)))))
cTxt(strcat(rtos eLen 2 Precision)Suffix)
tWid(caadr
(textbox
(list(cons 1 cTxt)
(cons 40 lab:Size)(cons 41 0.8))))
); end setq
(setq nTxt(Add_Masked_MText cTxt lPnt lab:Size (+ tWid(/ lab:Size 3)) 0.8 iAng BackMask))
(if Layer
(vla-put-Layer nTxt Layer)
); end if
(vla-EndUndoMark aDoc)
); end foreach
); end progn
(princ "\n Nothing selected ")
); end if
(princ)
); end of c:lmark
(c:lm)