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)

Advertisements

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


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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

Numeric Texts, Linear Dimensions and numeric block Attributes Sum Report as txt file with text string in format A+B+C+.. = Sum


;; Numeric Texts, Linear Dimensions and Numeric Block Attributes Sum Report as txt file with text string in format A+B+C+.. = Sum
;; Created by Dlanor 2018 (thanks to Tim Willey)
;; 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:tx() (c:addtxts)). If you change the main routine name
;; you will need to update the "shortcut" as well
;; so type "addtxts" or "tx" 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:tx () (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") "Dimension Export Report.txt") ;< e_len 2)
(setq ent (car (nth (1- e_len) ent)))
(setq ent (car ent))
);end_if
(setq obj (vlax-ename->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 " + " (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))
f_ptr (open file_name "a")
);end_setq
(write-line " " 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:tx)

Draw Road Chainage


;;; Draw Road Chainage
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-changing-to-station-from-chainage/td-p/7914389

(defun div-error (msg)
(if
(vl-position
msg
'("console break"
"Function cancelled"
"quit / exit abort"
)
)
(princ "Error!")
(princ msg)
)
(while (> (getvar "cmdactive") 0) (command))
;;; (command "._undo" "_end")
;;; (command "._u")
(setq *error* olderror)
(princ)
)

(defun divplus (len segm / num lst)
(setq num (fix (/ len segm)))
(setq cnt 0)
(while (= len 0.)
(setq lst (append lst (list len)))
(setq len (- len segm))
)
(if (not (zerop (last lst)))
(setq lst (append lst (list 0.0)))
)
lst
)

(defun alg-ang (obj pnt)
(angle '(0. 0. 0.)
(vlax-curve-getfirstderiv
obj
(vlax-curve-getparamatpoint
obj
pnt
)
)
)
)

(defun answer (quest / wshl ans)
(or (vl-load-com))
(setq wshl (vlax-get-or-create-object "WScript.Shell"))
(setq ans (vlax-invoke-method
wshl
'Popup quest 7 "Answer This Question:" vlax-vbYesNo))
(vlax-release-object wshl)
(cond ((= ans 6)
(setq opt T))
((= ans 7)
(setq opt nil))
)
opt
)

(defun make-station (bname / acsp adoc atprom attag at_obj
blk_obj hgt lay line_obj sfar )

(vl-load-com)
(setq adoc (vla-get-activedocument
(vlax-get-acad-object)
)
)
(if (and
(= (getvar "tilemode") 0)
(= (getvar "cvport") 1)
)
(setq acsp (vla-get-paperspace adoc))
(setq acsp (vla-get-modelspace adoc))
)
(vla-startundomark adoc)

(if (not (tblsearch "block" bname))
(progn
(setq attag "NUMBER" ;(strcase (getstring "\nAttribute tag : \n"))
atprom "NUMBER" ;(strcase (getstring T "\nAttribute prompt : \n"))
hgt 1.0 ;(getreal "\nAttribute text height : \n")
)

(setq lay (getvar "clayer"))
(setvar "clayer" "0")
(setvar "attreq" 0)

(setq line_obj (vlax-invoke acsp 'Addline '(0. 0. 0.) (list 0. (* hgt 12.) 0.)))
(vla-put-color line_obj acred)
(setq blk_obj (vla-add (vla-get-blocks adoc) (vlax-3d-point '(0. 0. 0.)) bname)
sfar (vlax-safearray-fill
(vlax-make-safearray vlax-vbObject '(0 . 0))
(list line_obj)
)
)
(vla-copyobjects adoc sfar blk_obj)
;;; RetVal = object.AddAttribute(Height, Mode, Prompt, InsertionPoint, Tag, Value)
(setq at_obj (vla-addattribute blk_obj
hgt
acattributemodeverify
atprom
(vlax-3d-point '(-0.5 1. 0.))
attag
"0+00")
)
;;; (vla-put-alignment at_obj acAlignmentBottomCenter)
;;; (vla-put-textalignmentpoint
;;; at_obj
;;; (vlax-3d-point '(0. 1. 0.))
;;; )
(vla-put-rotation at_obj (/ pi 2))
(vlax-release-object blk_obj)
)
(progn
(princ "\n\t >> Block does already exist!\n")
(princ)))
(if (tblsearch "block" bname)
T
(progn
(alert "Impossible to add block")))
(setvar "attreq" 1)
(setvar "clayer" lay)
(vl-catch-all-apply (function (lambda ()(vla-delete line_obj))))
(vla-regen adoc acactiveviewport)
(vla-endundomark adoc)
(vlax-release-object acsp)
(vlax-release-object adoc)
(princ)
)

(or (vl-load-com))
(defun C:dc (/ *error* acsp adoc appd div-error
len num olderror pl pt pt_list
step util
)

(or adoc
(setq adoc
(vla-get-activedocument
(vlax-get-acad-object)
)
)
)
(or appd (setq appd (vla-get-application adoc)))
(or acsp
(setq acsp
(vla-get-block
(vla-get-activelayout adoc)
)
)
)
(or util (setq util (vla-get-utility adoc)))
;;; (command "._undo" "_end")
;;; (command "._undo" "_mark")
(setq olderror *error*)
(setq *error* div-error)
;;; (setq bname (getstring T "\nStation block name : \n"))
;;; (make-station bname)
(if (not (tblsearch "block" "Station"))
(make-station "Station"))

(vla-getentity
util
'pl
'pt
"\nSelect line NEAR OF POINT TO START measure: >>> \n"
)
(if pl
(progn
(setq step (getreal "\nEnter step for stationing : \n"))
(setq opt (answer "Rotate text perpendicularly to pline?"))
(if (not step)(setq step 10.))

(setq len (vlax-curve-getdistatparam
pl
(vlax-curve-getendparam pl)
)
)

(if (list pt)
(vlax-curve-getstartpoint pl)
)
(distance (vlax-safearray->list pt)
(vlax-curve-getendpoint pl)
)
)
(setq pt_list (divplus len step))
(setq pt_list (divminus len step))
)

(setq
pt_list (vl-remove-if
(function not)
(mapcar (function (lambda (x)
(vlax-curve-getpointatdist pl x)
)
)
pt_list
)
)
)

(setq num 0)
;;; (setq num (getint "\nEnter initial station number\n"))
(mapcar
(function
(lambda (x / dr ang att_list at blk_obj)
(progn

(setq ang (alg-ang pl x)
ang
(cond ((< (/ pi 2) ang (* pi 1.5)) (+ pi ang))
(T ang)
)
)
(setq blk_obj (vlax-invoke
acsp 'Insertblock x "Station" 1 1 1 ang)
)
(setq att_list (vlax-invoke blk_obj 'Getattributes))
(foreach at att_list
(if (eq (vlax-get at 'Tagstring) "NUMBER")
(progn
(vlax-put at 'Textstring (if (< num 990.)
(strcat "CH: 0+" (rtos num 2 2))
(strcat "CH: "
(itoa (fix (/ num 1000.)));<--- changes 1200. on num (typo)
"+"
(rtos (- num (* (fix (/ num 1000.)) 1000)) 2 2)
)
))
(if (not opt)
(vlax-put at 'Rotation 0))
(vla-update at)
)
)
)
(vla-update blk_obj)
(vlax-release-object blk_obj)
(setq num (+ num step))
)
)
)
pt_list
)

(if (not (vlax-object-released-p pl))
(vlax-release-object pl)
)
)
(princ "\nNothing selected try again\n")
)
(vla-zoomextents appd)
(vla-regen adoc acactiveviewport)
(setq *error* olderror
div-error nil
)
;;; (command "._undo" "_end")
(princ)
)
(prompt "\n")
(prompt "\n *** Type DC to execute *** \n")
(princ)
(c:dc)

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


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

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

Replace selected blocks with a different one (replacing blocks and transferring attributes and some properties like layer, rotation and scale).


;;; Replace selected blocks with a different one
;;;(replacing blocks and transferring attributes and some properties like layer, rotation and scale).
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-only-selected-blocks-with-a-different-one-lisp/td-p/6933210

(defun c:cbb(/ iCnt bSet cFlg nBlc cVal pLst
bNam aLst aDoc nBlc aSp cAt rLst)

(vl-load-com)

(defun Set_Initial_Setenv(varLst)
(mapcar
'(lambda(v)(if(not(getenv(car v)))(setenv(car v)(cadr v))))
varLst)
); end of Set_Initial_Setenv

(defun Unblock_All_Layers(/ aDoc layCol actLay outLst)
(setq aDoc(vla-get-ActiveDocument
(vlax-get-acad-object))
layCol(vla-get-Layers aDoc)
actLay(vla-get-ActiveLayer aDoc)
); end setq
(vlax-map-collection layCol
(function
(lambda(x)
(setq outLst
(cons
(list x
(vla-get-Lock x)
(vla-get-Freeze x)
)outLst)
); end setq
(vla-put-Lock x :vlax-false)
(if(not(equal x actLay))
(vla-put-Freeze x :vlax-false)
); end if
); end lambda
); end function
); end vlax-map-collection
outLst
); end of Unblock_All_Layers

(defun Restore_All_Layer_States(Lst / actLay)
(setq actLay(vla-get-ActiveLayer
(vla-get-ActiveDocument
(vlax-get-acad-object))))
(mapcar
(function
(lambda(x)
(vla-put-Lock(car x)(cadr x))
(if(not(equal actLay(car x)))
(vla-put-Freeze(car x)(last x))
); end if
)
)
Lst
)
(princ)
); end of Restore_All_Layer_States

(Set_Initial_Setenv '(("xchange:layer" "Yes")("xchange:scale" "Yes")
("xchange:rotation" "Yes")("xchange:attributes" "Yes")))
(princ "\n<<>> ")
(if(setq bSet(ssget '((0 . "INSERT"))))
(progn
(while(not cFlg)
(princ
(strcat "\nOptions: Layer = "(getenv "xchange:layer")
", Scale = " (getenv "xchange:scale")
", Rotation = " (getenv "xchange:rotation")
", Attributes = " (getenv "xchange:attributes")))
(initget "Options")
(setq nBlc(entsel "\nSelect new block or [Options] > "))
(cond
((and
(= 'LIST(type nBlc))
(equal '(0 . "INSERT")(assoc 0(entget(car nBlc))))
); end and
(setq nBlc(vlax-ename->vla-object(car nBlc))
cFlg T); end setq
); end condition #1
((= 'LIST(type nBlc))
(princ "\n This isn't block ")
); end condition #2
((= "Options" nBlc)
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block layer [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:layer" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block scale [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:scale" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block rotation [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:rotation" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit attributes with similar tags [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:attributes" cVal))
); end condition #3
); end cond
); end while
(setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object))
bNam(vla-get-Name nBlc)
aSp(vla-ObjectIdToObject aDoc(vla-get-OwnerId nBlc))
iCnt 0
); end setq
(vla-StartUndoMark aDoc)
(setq rLst(Unblock_All_Layers))
(foreach b(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp
(mapcar 'cadr(ssnamex bSet))))
(if(= :vlax-true(vla-get-HasAttributes b))
(setq aLst
(mapcar '(lambda (a)
(list (vla-get-TagString a)
(vla-get-TextString a)))
(vlax-safearray->list
(vlax-variant-value (vla-GetAttributes b)))))
); end if
(setq nBlc(vla-InsertBlock aSp (vla-get-InsertionPoint b)bNam 1.0 1.0 1.0 0.0))
(if(= "Yes"(getenv "xchange:layer"))
(vla-put-Layer nBlc(vla-get-Layer b))
); end if
(if(= "Yes"(getenv "xchange:scale"))
(progn
(vla-put-XScaleFactor nBlc(vla-get-XScaleFactor b))
(vla-put-YScaleFactor nBlc(vla-get-YScaleFactor b))
(vla-put-ZScaleFactor nBlc(vla-get-ZScaleFactor b))
); end progn
); end if
(if(= "Yes"(getenv "xchange:rotation"))
(vla-put-Rotation nBlc(vla-get-Rotation b))
); end if
(if
(and
(= "Yes"(getenv "xchange:attributes"))
(= :vlax-true(vla-get-HasAttributes nBlc))
); end and
(foreach i(mapcar '(lambda (a)(list(vla-get-TagString a)a))
(vlax-safearray->list
(vlax-variant-value(vla-GetAttributes nBlc))))
(if(setq cAt(assoc(car i)aLst))
(vla-put-TextString(last i)(last cAt))
); end if
); end foreach
); end if
;(vla-Delete b)
(setq iCnt(1+ iCnt))
); end foreach
(Restore_All_Layer_States rLst)
(vla-EndUndoMark aDoc)
(princ(strcat "\n" (itoa iCnt) " block(s) was replaced. "))
); end progn
(princ "\n Nothing selected " )
); end if
(princ)
);
(alert "\nMake select similar on All background blocks before invoke CBB")
(princ "\nType CBB to replace or add blocks")
(c:cbb)

Convert straight to arc segments in multiple polylines at once


;;; Convert straight to arc segments in multiple polylines at once
;;; Created by Marko Ribar
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/convert-polyline-line-segments-to-arc-segments/m-p/5814922/highlight/true#M335051

(defun c:p2a
(/ massoclst nthmassocsubst v^v unit _ilp d doc lw enx gr enxb p p1 p2 p3 b i n)
(vl-load-com)
(defun massoclst (key lst)
(if (assoc key lst)
(cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst))))
)
)
(defun nthmassocsubst (n key value lst / k slst p j plst m tst pslst)
(setq k (length (setq slst (member (assoc key lst) lst))))
(setq p (- (length lst) k))
(setq j -1)
(repeat p (setq plst (cons (nth (setq j (1+ j)) lst) plst)))
(setq plst (reverse plst))
(setq j -1)
(setq m -1)
(repeat k
(setq j (1+ j))
(if (equal (assoc key (member (nth j slst) slst)) (nth j slst) 1e-6)
(setq m (1+ m))
)
(if (and (not tst) (= n m))
(setq pslst (cons (cons key value) pslst)
tst t
)
(setq pslst (cons (nth j slst) pslst))
)
)
(setq pslst (reverse pslst))
(append plst pslst)
)
(defun v^v (u v)
(mapcar
'(lambda (s1 s2 a b) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u)))))
'(+ - +)
'(- + -)
'(1 0 0)
'(2 2 1)
)
)
(defun unit (v) (mapcar '(lambda (x) (/ x (distance '(0.0 0.0 0.0) v))) v))
(defun _ilp (p1 p2 o nor / p1p p2p op tp pp p)
(if (not (equal (v^v nor (unit (mapcar '- p2 p1))) '(0.0 0.0 0.0) 1e-7))
(progn
(setq p1p (trans p1 0 (v^v nor (unit (mapcar '- p2 p1))))
p2p (trans p2 0 (v^v nor (unit (mapcar '- p2 p1))))
op (trans o 0 (v^v nor (unit (mapcar '- p2 p1))))
op (list (car op) (cadr op) (caddr p1p))
tp (polar op
(+ (* 0.5 pi)
(angle '(0.0 0.0 0.0) (trans nor 0 (v^v nor (unit (mapcar '- p2 p1)))))
)
1.0
)
)
(if (inters p1p p2p op tp nil)
(progn (setq p (trans (inters p1p p2p op tp nil) (v^v nor (unit (mapcar '- p2 p1))) 0)) p)
nil
)
)
(progn (setq pp (list (car (trans p1 0 nor)) (cadr (trans p1 0 nor)) (caddr (trans o 0 nor))))
(setq p (trans pp nor 0))
p
)
)
)
(or doc (setq doc (vla-get-activedocument (vlax-get-acad-object))))
(vla-startundomark doc)
;; RJP - added multiple selection 04.02.2018
(if (setq s (ssget ":L" '((0 . "lwpolyline"))))
(foreach lw (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
(setq i (fix (vlax-curve-getparamatpoint
lw
(vlax-curve-getclosestpointtoprojection
lw
(trans (setq p (vlax-curve-getstartpoint lw)) 1 0)
'(0.0 0.0 1.0)
)
) ;_ vlax-curve-getParamAtPoint
) ;_ fix
p1 (vlax-curve-getpointatparam lw i)
p3 (vlax-curve-getpointatparam lw (1+ i))
)
(setq enxb (massoclst 42 (setq enx (entget lw))))
(setq p2 (_ilp (trans p 1 0)
(mapcar '+ (trans p 1 0) '(0.0 0.0 1.0))
p1
(cdr (assoc 210 (entget lw)))
)
)
(setq
b ((lambda (a) (/ (sin a) (cos a)))
(/ (- (angle (trans p2 0 lw) (trans p3 0 lw)) (angle (trans p1 0 lw) (trans p2 0 lw)))
2.0
)
)
)
(setq n -1)
(foreach dxf42 enxb
(setq n (1+ n))
(if (= n i)
(setq enx (nthmassocsubst n 42 b enx))
(setq enx (nthmassocsubst n 42 (+ (cdr dxf42) b) enx))
)
)
(entupd (cdr (assoc -1 (entmod enx))))
)
(prompt "\n Nothing selected or picked object not a LWPOLYLINE ")
)
(vla-endundomark doc)
(princ)
)
(c:p2a)

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


; Dimmension Sum Report as txt file with text string in format A+B+C+.. = Sum
; Modified by Igal Averbuh 2018 and
; Deeply improved by pbejse
; Saved from: https://forums.autodesk.com/t5/user/viewprofilepage/user-id/564264
; Based on mfuccaro@hotmail.com routine with Enhancements by CAD Studio, 2012 and Tharwat routine
; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/routine-to-sum-multiples-dimensions/td-p/5268327

(setq _dimexpdelimiter "+") ; set to ";" for CSY/DEU...

(defun C:Ds ( / string_forExport valuetoadd s tx fn i d dl m file)

(if (setq iz 0.
string_forExport nil
s (ssget (list '(0 . "DIMENSION"))))
((lambda (% / sn)
(while (setq sn (ssname s (setq % (1+ %))))
(setq sn (vlax-ename->vla-object sn))
(setq valuetoadd
(if (numberp (setq to (read (vla-get-TextOverride sn))))
to (vla-get-measurement sn)))
(setq string_forExport (cons (strcat _dimexpdelimiter (rtos valuetoadd 2 1))
string_forExport))
(setq iz (+ valuetoadd iz))
)
)
-1
)
)
(if (> iz 0.)
(progn
(princ (strcat "\nTotal: " (rtos iz 2 1)))
(setq tx nil
fn (strcat (getvar "dwgprefix") "Dimension Export Report.txt"))
(setq file (open fn "a")) ; append
(write-line "" file)
(princ (strcat (substr (apply 'strcat string_forExport) 2) " = " (rtos iz 2 1)) file)
(close file)
(princ (strcat "\n" (itoa (length tx)) " dimensions written to " fn))
(startapp "notepad.exe" fn)
)
)
(princ)
)
(c:ds)

;|«Visual LISP© Format Options»
(72 6 40 0 nil "end of " 60 6 0 0 nil nil T nil T)
;*** DO NOT add text below the comment! ***|;

Draw Quadratic Dynamic Zig-Zag Polyline


;; Draw Quadratic Dynamic Zig-Zag Polyline - Created by Lee Mac
;; Saved from: http://www.cadtutor.net/forum/showthread.php?74752-Lisp-for-drawing-polylines
;; Modified by Igal Averbuh 2018

(defun c:dzg ( / a d g i l p q r x y )
(setq x (getdist (strcat "\nSpecify Weld Length: "))
y (getdist (strcat "\nSpecify Weld Width: "))
i (/ pi 2.0)
)

(while

(if (setq p (getpoint "\nSpecify 1st or Next Point: "))
(progn
(princ "\nSpecify 2nd Point [+/-] : ")
(while
(progn
(setq g (grread t 15 0)
q (cadr g)
g (car g)
)
(cond
( (member g '(3 5))
(redraw)
(setq a (angle p q)
d (distance p q)
i (abs i)
r p
)
(repeat (fix (/ d x))
(grdraw r (setq r (polar r a x)) 1 1)
(grdraw r (setq r (polar r (+ a (setq i (- i))) y)) 1 1)
)
(if (not (equal 0.0 (rem d x) 1e-8))
(grdraw r (polar r a (rem d x)) 1 1)
)
(= 5 g)
)
( (= 2 g)
(cond
( (member q '(43 61))
(setq x (1+ x))
)
( (member q '(45 95))
(setq x (max (1- x) 1))
)
)
)
)
)
)
(if (= 3 g)
(progn
(setq i (abs i)
p (trans p 1 0)
q (trans q 1 0)
a (angle p q)
)
(repeat (fix (/ d x))
(setq l (cons (cons 10 p) l)
l (cons (cons 10 (setq p (polar p a x))) l)
l (cons (cons 10 (setq p (polar p (+ a (setq i (- i))) y))) l)
)
)
(if (not (equal 0.0 (rem d x) 1e-8))
(setq l (cons (cons 10 (polar p a (rem d x))) l))
)
(entmake
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length l))
'(70 . 0)
)
(reverse l)
)
)
)
)
)
(redraw)
)

)

(princ)
)
(c:dzg)