Select entities by color property. (Routine allows from a pick in just one entity, select all entities in drawing that have the same color property)


;;; Select entities by color property
;;; Routine allows from a pick in just one entity, select all entities in drawing that have the same color property.
;;; Created by Lee Mac
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?62842-Select-entities-by-color-property.

(defun c:fbc ( / c d e l )
(if (setq e (car (entsel)))
(progn
(setq c
(cond
( (cdr (assoc 62 (entget e))) )
( (abs (cdr (assoc 62 (tblsearch "LAYER" (cdr (assoc 8 (entget e))))))) )
)
)
(while (setq d (tblnext "LAYER" (null d)))
(if (= c (abs (cdr (assoc 62 d))))
(setq l (cons "," (cons (cdr (assoc 2 d)) l)))
)
)
(sssetfirst nil
(ssget "_X"
(if l
(list
(cons -4 "<OR")
(cons 62 c)
(cons -4 "")
(cons -4 "OR>")
)
(list (cons 62 c))
)
)
)
)
)
(princ)
)
(c:fbc)

Advertisements

AutoCAD Drawing Version determination (Updated Lee Mac routine for AutoCAD 2018-2019 releases)


;; Drawing Version - Lee Mac
;; Returns the version of the supplied filename (dwg/dws/dwt/dxf)
;; Updated for 2018 - 2019 Autocad versions by Igal Averbuh 2018
(defun LM:dwgversion ( fn / fd vr )
(cond
( (null
(and
(setq fn (findfile fn))
(setq fd (open fn "r"))
)
)
)
( (wcmatch (strcase fn t) "*`.dw[gst]")
(setq vr (strcase (substr (read-line fd) 1 6)))
)
( (wcmatch (strcase fn t) "*`.dxf")
(repeat 7 (read-line fd))
(setq vr (strcase (read-line fd)))
)
)
(if (= 'file (type fd)) (close fd))
(cdr
(assoc vr
'(
("AC1032" . "2018-2019")
("AC1027" . "2013-2015")
("AC1024" . "2010-2012")
("AC1021" . "2007-2009")
("AC1018" . "2004-2006")
("AC1015" . "2000-2002")
("AC1014" . "Release 14")
("AC1012" . "Release 13")
("AC1009" . "Release 11/12")
("AC1006" . "Release 10")
("AC1004" . "Release 9")
("AC1003" . "Release 2.60")
("AC1002" . "Release 2.50")
("AC1001" . "Release 2.22")
("AC2.22" . "Release 2.22")
("AC2.21" . "Release 2.21")
("AC2.10" . "Release 2.10")
("AC1.50" . "Release 2.05")
("AC1.40" . "Release 1.40")
("AC1.2" . "Release 1.2")
("MC0.0" . "Release 1.0")
)
)
)
)

;; Prints the version of the active drawing file

(defun c:dwgver ( / vr )
(if (zerop (getvar 'dwgtitled))
(princ "\nThe current drawing is unsaved.")
(if (setq vr (LM:dwgversion (strcat (getvar 'dwgprefix) (getvar 'dwgname))))
(princ (strcat "\nThis is an AutoCAD " vr " format file."))
(princ "\nThe format of this file could not be determined.")
)
)
(princ)
)
(c:dwgver)

Change Color of selected objects to used defined Index color number


;;; Change Color of selected objects to used defined Index color number
;;; Created by Lee Mac
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?31679-Simple-colour-change-lisp
;;; Slightly modified by Igal Averbuh 2018 (changed priority of some commands)

(defun c:coc (/ usercol ss)
(prompt "Select objects to change color:")
(setq ss (ssget))
(setq usercol (acad_colordlg 256))
(command "_.ChProp" ss "" "_C" usercol "")
(princ))

(c:coc)

Change Color of selected objects to used defined Index color number or via dialog box


;;; Change Color of selected objects to used defined by Index color number or via dialog box
;;; Created by neophoible
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?81744-Selected-Objects-to-color-LISP/page2

(defun C:COC (/ ColorObjects CurrColorOrg NewColor CmdEchoOrg)
(prompt "\nSelect objects to change color...")
(cond
( (setq ColorObjects (ssget))
(setq CurrColorOrg (getvar 'CECOLOR)
CmdEchoOrg (getvar 'CMDECHO)
)
(setvar 'CMDECHO 0)
(while
(not (cond
( (initget 6) )
( (setq NewColor (getint
"\nEnter object color (1-255) : "
) )
(if (< NewColor 256) (setvar 'CECOLOR (itoa NewColor)))
)
(T(initdia)
(command "_.COLOR")
(numberp (read (getvar 'CECOLOR)))
)
) )
(prompt "\nCannot set color to that value.\n*Invalid.*")
)
(command "_.CHANGE" ColorObjects "" "_P" "_C" (getvar 'CECOLOR) "")
) )
(setvar 'CECOLOR CurrColorOrg)
(setvar 'CMDECHO CmdEchoOrg)
(princ)
)
(c:coc)

Remove background color from all hatches at once


; Remove background color from all hatches at once

; Created by Igal Averbuh 2015 (based on existing routines)

;;Recreate-Hatch-Boundaries.lsp written by Murray Clack, November 19, 2010
;;;Recreate multiple hatch boundaries as polygons, each in the layer as his hach.
(prompt "\nRecreate-Hatch-Boundaries.lsp loaded, Enter HB to execute")
(defun c:HB (/ OLDCE SSET CNT OBJ)
(setq OLDCE (getvar "cmdecho"))
(setvar "cmdecho" 0)
;(princ "\nSelect Hatch Objects: ")
;(setq SSET (ssget))
(setq SSET (ssget "X" '((0 . "HATCH"))))
(setq CNT -1)
(while (setq OBJ (ssname SSET (setq CNT (1+ CNT))))
(setvar 'clayer (cdr (assoc 8 (entget OBJ))))
(command "-hatchedit" OBJ "b" "p" "n")
)
(setvar "cmdecho" OLDCE)
(princ)
)

(defun c:hed()
(initcommandversion)
(command "-hatchedit" "P" "" "CO" "" ".")

(princ)
)

(defun C:ras (/ SETD LAY)

(setvar "CMDECHO" 0)

(setq SETD (ssget "X" '((0 . "HATCH"))))

(if (null SETD)

(princ "\nThere are no associated hatches.")

(progn

(c:hed)
(c:hb)
(command "regen")
)

)

(setvar "CMDECHO" 1)

(princ)

)

(C:ras)

Remove background color from selected hatches at once

; Remove background color from selected hatches at once

; Created by Igal Averbuh 2015 (based on existing routines)

(defun c:hed()
(initcommandversion)
(command "-hatchedit" "P" "" "CO" "" ".")
(princ)
)

;;Recreate-Hatch-Boundaries.lsp written by Murray Clack, November 19, 2010
;;;Recreate multiple hatch boundaries as polygons, each in the layer as his hach.
(prompt "\nRecreate-Hatch-Boundaries.lsp loaded, Enter HB to execute")
(defun c:HB (/ OLDCE SSET CNT OBJ)
(setq OLDCE (getvar "cmdecho"))
(setvar "cmdecho" 0)
;(princ "\nSelect Hatch Objects: ")
;(setq SSET (ssget))
(setq SSET (ssget "X" '((0 . "HATCH"))))
(setq CNT -1)
(while (setq OBJ (ssname SSET (setq CNT (1+ CNT))))
(setvar 'clayer (cdr (assoc 8 (entget OBJ))))
(command "-hatchedit" OBJ "b" "p" "n")
)
(setvar "cmdecho" OLDCE)
(princ)
)

;; Select HATCH by: Layer, Pattern Name, Pattern Scale, Colour & Background Colour
;; by 3dwannb on 11.04.17
;;
;; Help by GRRR: http://www.cadtutor.net/forum/showthread.php?100136-Select-Hatch-by-background-color&p=681038&viewfull=1#post681038
;;
;; Known Bugs: None
;;
(defun c:QS_HLPSCB nil (c:QS_HATCH_SAME_Layer_PatternName_PatternScale_Color_&_BkgColor))
(defun c:QS_HATCH_SAME_Layer_PatternName_PatternScale_Color_&_BkgColor ( /
bkgCol
layColor
layer
patName
patScale
ss
nSS
ssdata
)
(while
(not
(and
(setq
ss (car (entsel "\nSelect Hatch to get same Hatch entities as:\nLayer, Pattern Name, Pattern Scale, Colour & Background Colour :"))
ssdata (if ss (entget ss))
)
(= (cdr (assoc 0 ssdata)) "HATCH")
(sssetfirst nil)
(setq ss (vlax-ename->vla-object ss))
(progn
(setq
bkgCol (vla-get-backgroundcolor ss)
bkgCol (vla-get-ColorIndex (vla-get-BackgroundColor ss))
layColor (vla-get-color ss)
layer (vla-get-Layer ss)
patName (vla-get-PatternName ss)
patScale (vla-get-PatternScale ss)
ss (ssget "X" (list (cons 8 layer) '(0 . "HATCH") (cons 2 patName) (cons 62 layColor) (cons 41 patScale) (cons 410 (getvar 'ctab))))
nSS (ssadd)
)
(repeat (setq i (sslength ss))
(and
(setq e (ssname ss (setq i (1- i))))
(= bkgCol (vla-get-ColorIndex (vla-get-BackgroundColor (vlax-ename->vla-object e))))
(ssadd e nSS)
)
)
(princ (strcat "\n >>> " (itoa (setq len (sslength nSS))) (if (> len 1) " items" " item") " selected <<>> Nothing selected or not a Hatch ! <<< ")
)
(princ)
)
(vl-load-com)
;(princ "\n:: QS_HATCH_SAME_Layer_PatternName_PatternScale_Color_&_BkgColor.lsp | Version 1.0 | by 3dwannab ::")
;(princ "\n:: Type \"QS_HATCH_SAME_Layer_PatternName_PatternScale_Color_&_BkgColor\" OR \"QS_HLPSCB\" to Invoke ::") (princ)

(defun c:RC()

(c:QS_HLPSCB)
(c:hed)
(c:hb)
(command "regen")
)
(c:rc)

Select similar TEXT


;;; Select similar TEXT (not mtext.) You will be ask to select a source object. If you do that, the lisp will select all other texts containing the exact same text. If not and you just click enter, it will prompt for text pattern. The good part is that it will accept wildcards. for example, if you type “A#” it will select any of A0 A1 … A9. “A#*” will select any text stating with A, number, followed by any character(s). “A[123]” for selecting A1 A2 or A3 text
;;; Slightly modified by Igal Averbuh 2018 ( added option to select all similar text at onnce)
;;; Based on "KIM Eng. Solutions" routine
;;; Saved from: http://www.kimprojects.com/a-much-better-select-similar-autocad/
(defun C:SST ( / s1 obj lst s2 str)
(while
(princ "\nSelect source text:")
(if
(or
(if
(setq s1 (cadr (ssgetfirst)))
(setq str (if
(= 1 (sslength s1))
(cdr (assoc 1 (entget (ssname s1 0))))
(car (sssetfirst nil nil))
)
)
)
(if
(setq s1 (car (entsel)))
(setq str (cdr (assoc 1 (entget s1))))
)
(/= (setq str (getstring t "\nEnter the TEXT to select: ")) "")
(setq str "*")
)
(progn
(princ "\nSelect the other objects...")
(sssetfirst nil nil)
(setq flst (list '(0 . "*TEXT") (cons 1 str)))
(if
(setq s2 (ssget "_X" (list '(0 . "*TEXT") (cons 1 str))))
(princ (strcat (itoa (sslength s2)) " objects"))
)
(cadr (sssetfirst nil s2))
)
)
(if (zerop (getvar 'cmdactive)) (princ) (cadr (sssetfirst nil s2)))
;(c:zz)
)
)
(c:sst)

Draw Lighting Line with radial connection to Poles and option to “Unexlode” connected lines to Polyline


;;; Draw Lighting Line with radial connection to Poles and option to "Unexlode" connected lines to Polyline
;;; Based on CAB solution saved from: http://www.cadtutor.net/forum/showthread.php?36112-Electrical-Wiring-Lsp
;;; Combined with other subroutines and slightly modified by Igal Averbuh 2018 (added option to set radius of poles connection)

;;; Based on Lee Mak routines saved from: http://www.cadtutor.net/forum/showthread.php?92452-convert-lines-to-polyline-(where-endpoints-coincide)

;;--------------------=={ Chain Selection }==-----------------;;
;; ;;
;; Prompts the user to select an object and generates a ;;
;; selection chain of all objects sharing endpoints with ;;
;; objects in the accumulative selection. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2012 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;

(defun c:pj ( / *error* sel val var )

(defun *error* ( msg )
(mapcar '(lambda ( a b ) (if b (setvar a b))) var val)

(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(c:luo)
)
(princ)
)

(LM:startundo (LM:acdoc))
(if
(setq sel
(LM:ssget "\nPolyline was Unexploded "
'( "_:L"
(
(-4 . "<OR")
(0 . "LINE,ARC")
(-4 . "<AND")
(0 . "LWPOLYLINE")
(-4 . "")
(-4 . "AND>")
(-4 . "OR>")
)
)
)
)
(progn
(setq var '(cmdecho peditaccept)
val (mapcar 'getvar var)
)
(mapcar '(lambda ( a b c ) (if a (setvar b c))) val var '(0 1))
(command "_.pedit" "_m" sel "" "_j" "" "")
)
)
(*error* nil)
(princ)
)

(defun c:ccp ( / en fl in l1 l2 s1 s2 sf vl )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))

(setvar 'maxactvp 64)
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
(setvar 'maxactvp 64)
)
(princ)
)

(setq sf
(list
'(-4 . "<OR")
'(0 . "LINE,ARC")
'(-4 . "<AND")
'(0 . "LWPOLYLINE,SPLINE")
'(-4 . "")
'(-4 . "AND>")
'(-4 . "<AND")
'(0 . "POLYLINE")
'(-4 . "")
'(-4 . "AND>")
'(-4 . "<AND")
'(0 . "ELLIPSE")
'(-4 . "<OR")
'(-4 . "")
'(41 . 0.0)
'(-4 . "")
(cons 42 (+ pi pi))
'(-4 . "OR>")
'(-4 . "AND>")
'(-4 . "OR>")
(if (= 1 (getvar 'cvport))
(cons 410 (getvar 'ctab))
'(410 . "Model")
)
)
)
(if (setq s1 (ssget "_X" sf))
(if (setq en (ssget "_+.:E:S" sf))
(progn
(setq s2 (ssadd)
en (ssname en 0)
l1 (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en))
)
(repeat (setq in (sslength s1))
(setq en (ssname s1 (setq in (1- in)))
vl (cons (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en) en) vl)
)
)
(while
(progn
(foreach v vl
(if (vl-some '(lambda ( p ) (or (equal (car v) p 1e-8) (equal (cadr v) p 1e-8))) l1)
(setq s2 (ssadd (caddr v) s2)
l1 (vl-list* (car v) (cadr v) l1)
fl t
)
(setq l2 (cons v l2))
)
)
fl
)
(setq vl l2 l2 nil fl nil)
)
)
)
(princ "\nNo valid objects found.")
)
(sssetfirst nil s2)
(princ)
)
(vl-load-com) (princ)

(defun c:up ( / )
(princ "\nSelect Lighting Line to Join with other segments")
(c:ccp)
(c:pj)
)

;; Uniformly Scaled Block - Lee Mac
;; Returns T if the supplied VLA Block Reference is uniformly scaled
;; obj - [vla] VLA Block Reference

(defun LM:usblock-p ( obj / s )
(if (vlax-property-available-p obj 'xeffectivescalefactor)
(setq s "effectivescalefactor")
(setq s "scalefactor")
)
(eval
(list 'defun 'LM:usblock-p '( obj )
(list 'and
(list 'equal
(list 'vlax-get-property 'obj (strcat "x" s))
(list 'vlax-get-property 'obj (strcat "y" s))
1e-8
)
(list 'equal
(list 'vlax-get-property 'obj (strcat "x" s))
(list 'vlax-get-property 'obj (strcat "z" s))
1e-8
)
)
)
)
(LM:usblock-p obj)
)

;; entlast - Lee Mac
;; A wrapper for the entlast function to return the last subentity in the database

(defun LM:entlast ( / ent tmp )
(setq ent (entlast))
(while (setq tmp (entnext ent)) (setq ent tmp))
ent
)

;; ssget - Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;; msg - [str] selection prompt
;; arg - [lst] list of ssget arguments

(defun LM:ssget ( msg arg / sel )
(princ msg)
(setvar 'nomutt 1)
(setq sel (vl-catch-all-apply 'ssget arg))
(setvar 'nomutt 0)
(if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo - Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
(LM:endundo doc)
(vla-startundomark doc)
)

;; End Undo - Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
(while (= 8 (logand 8 (getvar 'undoctl)))
(vla-endundomark doc)
)
)

;; Active Document - Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
(eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
(LM:acdoc)
)

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

(vl-load-com)

;; LayerIsolateOnOff.lsp [command names: LIO, LUO]
;; To Isolate and Unisolate only the On-Off condition of Layers of selected objects.
;; LIO isolates Layers of selected objects, leaving those Layers on and turning all
;; other Layers off that are not already off. If repeated before LUO turns those
;; Layers back on, makes further isolations, to as many levels as desired.
;; LUO turns latest set of turned-off Layers back on, without undoing other Layer
;; options that may have been used under isolated conditions [as happens with
;; some (e.g. colors) if using AutoCAD's standard LAYERUNISO to return to un-
;; isolated conditions after using LAYISO]. When repeated, steps back through
;; as many isolations as were done with LIO [LAYISO can only step back once].
;; Kent Cooper, August 2011

(vl-load-com)

(defun liV (sub); = build Variable name with subtype and current integer ending
(read (strcat "li" sub (itoa liinc)))
); defun

(defun liG (sub); = Get what's in the above variable
(eval (read (strcat "li" sub (itoa liinc))))
); defun

(defun C:LIO (/ ss cmde laysel layname lion layobj); = Layer Isolate -- On-Off condition only
(prompt "\nSelect Layers to remain ON,")
(if (setq ss (ssget)); object selection
(progn
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(repeat (sslength ss); make list of Layer names to remain on
(setq laysel (cdr (assoc 8 (entget (ssname ss 0))))); Layer name
(if (not (member laysel lion)) (setq lion (cons laysel lion))); add if not already there
(ssdel (ssname ss 0) ss)
); repeat
(setq liinc (if liinc (1+ liinc) 1)); liinc is global; 1 for first time, etc.
(if
(set (liV "cur"); global variable(s), but need(s) to be:
(if (not (member (getvar 'clayer) lion)); nil if current Layer kept on
(vlax-ename->vla-object (tblobjname "layer" (getvar 'clayer)))
); if
); set
(setvar 'clayer (nth 0 lion)); then - make some selected object's Layer current
); if
(while (setq layname (cdadr (tblnext "layer" (not layname)))); step through Layers
(if
(and
(not (member layname lion)); not among selected objects' Layers
(> (cdr (assoc 62 (tblsearch "layer" layname))) 0); currently on
); and
(progn
(setq layobj (vlax-ename->vla-object (tblobjname "layer" layname)))
(set (liV "off") (cons layobj (liG "off")))
; put in list of Layers turned off -- makes global variables lioff1, lioff2, etc.
(vla-put-LayerOn layobj 0); turn off
); progn
); if
); while
(prompt
(strcat
"\n"
(itoa (length lion))
" Layer(s) isolated, "
(itoa (length (liG "off")))
" Layer(s) turned off."
(if (liG "cur")
(strcat " Layer " (getvar 'clayer) " has been made current."); then
"" ; else - add nothing to prompt if current Layer remains on
); if
); strcat
); prompt
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); progn
(prompt "\nNothing selected.")
); if
(princ)
); defun

(defun C:LUO (/ cmde lugone lucur); = Layer Unisolate -- On-Off condition only
(if (> liinc 0); at least one list of turned-off Layers exists
(progn ; then
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(foreach lay (liG "off"); latest numbered list
(if (vlax-vla-object->ename lay); still in drawing
(vla-put-LayerOn lay -1); then - turn on
(progn ; else
(vl-remove lay (liG "off")); to adjust number for prompt later
(setq lugone (if lugone (1+ lugone) 1)); quantity of no-longer-present Layers
); progn
); if
); foreach
(if ; restore Layer current at time of corresponding LIO if it was turned off
(and
(liG "cur"); nil if it wasn't
(vlax-vla-object->ename (liG "cur")); Layer still in drawing, even if renamed
); and
(progn
(setq lucur (vla-get-Name (liG "cur"))); present name if renamed since its LIO
(setvar 'clayer lucur); restore as current
); progn
); if
(prompt
(strcat
"\n"
(itoa (length (liG "off")))
" Layer(s) turned back on."
(if (liG "cur") ; corresponding LIO turned off current Layer at the time
(strcat ; then
"\nLayer "
(if (vlax-vla-object->ename (liG "cur")); still in drawing
(vla-get-Name (liG "cur")); then - name, even if renamed
"current at time of LIO purged, and not"
); if
" restored as current."
); strcat
"" ; else - add nothing if corresponding LIO kept current Layer on
); if
(if lugone (strcat "\n" (itoa lugone) " purged Layer(s) not turned back on.") "")
); strcat
); prompt
(set (liV "off") nil); clear list ending with latest integer in use
(set (liV "cur") nil); clear current-at-LIO-Layer-if-changed value with latest integer
(setq liinc (1- liinc)); increment downward for next-earlier list
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
); progn
(prompt "\nNo Layers to Unisolate."); else
); if
(princ)
); defun

;; CAB 05.12.09
;; Draw Electric Wire
(defun c:ew (/ ew_layer p1 p2 msg)
(setq ew_layer "BARTEURA") ; layer name
(SETQ PINS (GETdist "\nSet wire radius "))
(defun draw-ew (p4 p1 lay / p2 p3)
(setq p2 (polar p1 (- (angle p1 p4) (/ pi 8)) pins)
p3 (polar p4 (+ (angle p4 p1) (/ pi 8)) pins)
)
(entmakex
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 8 lay)
(cons 90 4)
'(70 . 0) ; 1 for closed 0 overwise
(cons 10 p1)
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.198912)
(cons 10 p2)
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
(cons 10 p3)
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.198913)
(cons 10 p4)
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)
)
)
)

(setq p1 (getpoint "\nPick start point (Draw clockwise"))
(setq msg "\nPick next point clockwise.")
(while (setq p2 (getpoint p1 msg))
(draw-ew p1 p2 ew_layer)
(setq p1 p2)
)

(princ)

)
(prompt "\nElectric Wire loaded, Enter EW to run.")
(princ)

(defun c:mf ( / )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))
(c:luo)

(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))

)
(princ)
)

(c:ew)
(c:lio)
(c:up)
(c:luo)
)
(c:mf)

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


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

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

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

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

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

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

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

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