• Add-On’s
  • Download
  • History of AutoLISP
  • Lisp Resources
  • Run an AutoLISP

LispBox

~ This blog was initially created for people, who love autolisp routines, as I love it.

Category Archives: Counting

Counting Lisps

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

07 Wednesday Aug 2019

Posted by danglar71 in Counting

≈ 2 Comments


;;; 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

05 Sunday May 2019

Posted by danglar71 in Counting, Vport

≈ Leave a comment


;;; 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

19 Tuesday Feb 2019

Posted by danglar71 in Blocks, Counting

≈ Leave a comment


;;; 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.

12 Wednesday Sep 2018

Posted by danglar71 in Counting

≈ Leave a comment


;;; ------------------------------------------------------------------------
;;; 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²)

23 Monday Apr 2018

Posted by danglar71 in Counting, Export, Utilites

≈ Leave a comment


;; 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²)

23 Monday Apr 2018

Posted by danglar71 in Counting, Export, Utilites

≈ Leave a comment


;; 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

12 Thursday Apr 2018

Posted by danglar71 in Counting, Lisp Collection 2014, Text, Utilites

≈ Leave a comment


; 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

06 Tuesday Mar 2018

Posted by danglar71 in Counting

≈ Leave a comment


;| 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

22 Thursday Sep 2016

Posted by danglar71 in Counting, Lisp Collection 2014

≈ Leave a comment


;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

19 Monday Sep 2016

Posted by danglar71 in Counting, draw

≈ Leave a comment


;;; 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)

← Older posts

Recent Posts

  • Это наша плата за трусость
  • Set the Default Application to open DWG Files
  • Draw “Heat Grid” (Lee Mac)
  • PROGRAM FOR SPRINKLER DISTRIBUTION
  • How to remove Frames around blocks

Recent Comments

Wilmer Lacayo on Draw Centroid (center of gravi…
Jun on Convert Polylines to Leaders i…
Adel on HVAC Draw Branch Duct
danglar71 on Draw “Heat Grid” (…
IOAN VLAD on Draw “Heat Grid” (…

Archives

  • January 2021
  • March 2020
  • February 2020
  • January 2020
  • October 2019
  • September 2019
  • August 2019
  • July 2019
  • June 2019
  • May 2019
  • April 2019
  • February 2019
  • January 2019
  • December 2018
  • November 2018
  • October 2018
  • September 2018
  • August 2018
  • July 2018
  • June 2018
  • April 2018
  • March 2018
  • February 2018
  • January 2018
  • December 2017
  • November 2017
  • August 2017
  • July 2017
  • June 2017
  • May 2017
  • April 2017
  • March 2017
  • February 2017
  • January 2017
  • December 2016
  • November 2016
  • October 2016
  • September 2016
  • August 2016
  • July 2016
  • June 2016
  • May 2016
  • April 2016
  • March 2016
  • February 2016
  • January 2016
  • December 2015
  • November 2015
  • October 2015
  • September 2015
  • August 2015
  • July 2015
  • June 2015
  • May 2015
  • April 2015
  • March 2015
  • February 2015
  • January 2015
  • December 2014
  • November 2014

Categories

  • 3D
  • Annonymous Blocks
  • Attribute
  • Batch
  • Blocks
  • Books
  • Common
  • Coordinates
  • Counting
  • dimmensions
  • draw
  • Export
  • Fractal
  • Hatch
  • HVAC
  • Images
  • Import
  • Info
  • Isometric
  • Layers
  • Layouts
  • Lisp Collection 2014
  • Mline
  • Pdf
  • Pipes
  • plot
  • Points
  • Protect
  • Text
  • Tips (English)
  • Tips (Russian)
  • ucs
  • Utilites
  • view
  • Vport
  • Xref

Recent Posts

  • Это наша плата за трусость
  • Set the Default Application to open DWG Files
  • Draw “Heat Grid” (Lee Mac)
  • PROGRAM FOR SPRINKLER DISTRIBUTION
  • How to remove Frames around blocks

Recent Comments

Wilmer Lacayo on Draw Centroid (center of gravi…
Jun on Convert Polylines to Leaders i…
Adel on HVAC Draw Branch Duct
danglar71 on Draw “Heat Grid” (…
IOAN VLAD on Draw “Heat Grid” (…

Archives

  • January 2021
  • March 2020
  • February 2020
  • January 2020
  • October 2019
  • September 2019
  • August 2019
  • July 2019
  • June 2019
  • May 2019
  • April 2019
  • February 2019
  • January 2019
  • December 2018
  • November 2018
  • October 2018
  • September 2018
  • August 2018
  • July 2018
  • June 2018
  • April 2018
  • March 2018
  • February 2018
  • January 2018
  • December 2017
  • November 2017
  • August 2017
  • July 2017
  • June 2017
  • May 2017
  • April 2017
  • March 2017
  • February 2017
  • January 2017
  • December 2016
  • November 2016
  • October 2016
  • September 2016
  • August 2016
  • July 2016
  • June 2016
  • May 2016
  • April 2016
  • March 2016
  • February 2016
  • January 2016
  • December 2015
  • November 2015
  • October 2015
  • September 2015
  • August 2015
  • July 2015
  • June 2015
  • May 2015
  • April 2015
  • March 2015
  • February 2015
  • January 2015
  • December 2014
  • November 2014

Categories

  • 3D
  • Annonymous Blocks
  • Attribute
  • Batch
  • Blocks
  • Books
  • Common
  • Coordinates
  • Counting
  • dimmensions
  • draw
  • Export
  • Fractal
  • Hatch
  • HVAC
  • Images
  • Import
  • Info
  • Isometric
  • Layers
  • Layouts
  • Lisp Collection 2014
  • Mline
  • Pdf
  • Pipes
  • plot
  • Points
  • Protect
  • Text
  • Tips (English)
  • Tips (Russian)
  • ucs
  • Utilites
  • view
  • Vport
  • Xref

Create a free website or blog at WordPress.com.

Privacy & Cookies: This site uses cookies. By continuing to use this website, you agree to their use.
To find out more, including how to control cookies, see here: Cookie Policy