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

Monthly Archives: April 2018

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, Linear Dimensions and numeric block Attributes Sum Report as txt file with text string in format A+B+C+.. = Sum

18 Wednesday Apr 2018

Posted by danglar71 in Export, Utilites

≈ 2 Comments


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

16 Monday Apr 2018

Posted by danglar71 in draw

≈ Leave a comment


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

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)

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

08 Sunday Apr 2018

Posted by danglar71 in Blocks, Utilites

≈ Leave a comment


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

03 Tuesday Apr 2018

Posted by danglar71 in draw, Utilites

≈ 4 Comments


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

02 Monday Apr 2018

Posted by danglar71 in dimmensions, Utilites

≈ Leave a comment


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

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