Dimension Text Style Assign to All


;;;; Dimension Text Style Assign to All
;;; Created by Kent1Cooper
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-change-textstyles-in-all-dimensions-and-leaders-in-an/td-p/7061539

(defun C:DS
(/ tblentry styname data)

(command "-style" "Igal" "arial.ttf" "" "" "0" "" "")

(while (setq tblentry (tblnext "dimstyle" (not tblentry))); step through Dim.Style entries
(setq
styname (cdr (assoc 2 tblentry)); Style name
data (entget (tblobjname "dimstyle" styname)); its entity data
); setq
(entmod
(subst
(cons 340 (tblobjname "STYLE" "Igal")); assign Text Style to it
(assoc 340 data)
data
); subst
); entmod
); while
(command "_.dimoverride" "DIMTXSTY" "Igal" "" "_all" ""); force it on already-drawn ones
(princ)
); defun
(c:ds)

Copy First Layout Multiple Times, Number Incrementally and Sort Alphabetical


;; Copy First Layout Multiple Times and Number Incrementally
;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/copy-first-layout-multiple-times-and-number-incrementally/td-p/7030955
;; Created by Ranjit.Singh
;; Slightly modified by Igal Averbuh 2017 (added layout sort function)

(defun C:TabSort (/ cnt doc lay)
(vl-load-com)
(setq cnt 1
doc (vla-get-activedocument (vlax-get-acad-object))
)
(foreach lay (acad_strlsort (vl-remove "Model" (layoutlist)))
(vla-put-taborder (vla-item (vla-get-layouts doc) lay) cnt)
(setq cnt (1+ cnt))
)
(princ)
)

(defun c:cll (/ a adoc curpos curtab i n)
(setvar "tilemode" 0)
(and (= 0 (getvar 'tilemode))
(setq i (getint "\nEnter Starting Layout number: ")
curtab (substr (getvar 'ctab) 1 (- (strlen (getvar 'ctab)) 2))
n (getint "\nHow many copies of this tab: "))
(repeat n
(command "._layout" "_copy" "" (strcat curtab (if (= 1 (strlen (setq a (itoa (+ (1- n) i)))))
(strcat "0" a)
a)))
(setq i (1- i)))))

(defun c:cl (/)
(c:cll)
(C:TabSort)
)
(c:cl)

Unexplode Polylines


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

;;--------------------=={ 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)
(LM:endundo (LM:acdoc))
(if (and msg (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(LM:startundo (LM:acdoc))
(if
(setq sel
(LM:ssget "\nPolyline was Unexploded "
'( "_:L"
(
(-4 . "<OR")
(0 . "LINE,ARC")
(-4 . "")
(-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 )
(setq sf
(list
'(-4 . "<OR")
'(0 . "LINE,ARC")
'(-4 . "")
'(-4 . "")
'(-4 . "<AND")
'(0 . "ELLIPSE")
'(-4 . "")
'(-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 ( / )
(c:ccp)
(c:pj)
)
(c:up)

Draw Grass at Elevation


;;; Draw Grass at Elevation
;;; Created by Ronjonp: https://www.theswamp.org/index.php?topic=52989.0
(defun c:gr(/ grass bpt d h intensity p1 p2 tilt top)
;; RJP - 04.28.2017
(defun getrandnum (minnum maxnum / randnum)
;; Getrandnum returns a real number between minNum and maxNum.
;;
;; By: Stig Madsen
(defun randnum (/ modulus multiplier increment random)
;; Randnum.lsp
;; Returns a random number.
;; Written by Paul Furman, 1996.
;; Based on algorithm by Doug Cooper, 1982.
(if (not seed)
(setq seed (getvar "DATE"))
)
(setq modulus 65536
multiplier 25173
increment 13849
seed (rem (+ (* multiplier seed) increment) modulus)
random (/ seed modulus)
)
)
(if (not (< minnum maxnum))
(progn (setq tmp minnum
minnum maxnum
maxnum tmp
)
)
)
(setq random (+ (* (randnum) (- maxnum minnum)) minnum))
)
(defun grass (p1 p2 / w)
(setq w -0.1)
(entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(67 . 0)
'(8 . "Grass")
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 128)
'(43 . 0.0)
'(38 . 0.0)
'(39 . 0.0)
(cons 10 p1)
'(40 . 0.0)
'(41 . 0.0)
(cons 42 (getrandnum w (+ w w)))
'(91 . 0)
(cons 10 p2)
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.1)
'(91 . 0)
(cons 10 p1)
'(40 . 0.0)
'(41 . 0.0)
(cons 42 (getrandnum w (+ w w)))
'(91 . 0)
(cons 10 p2)
'(40 . 0.0)
'(41 . 0.0)
'(42 . -11.5)
'(91 . 0)
)
)
)
(setq intensity 25)
(setq tilt 0.2)
(if (and (or (setq h (getdist "\nEnter maximum grass height : ")) (setq h 0.5))
(setq p1 (getpoint "\nSpecify first point: "))
(setq d (getdist p1 "\nSpecify second point: "))
)
(repeat (fix (/ (* d intensity) h))
(setq bpt (list (getrandnum (car p1) (+ d (car p1))) (cadr p1)))
(setq top (list (getrandnum (car bpt) (+ (getrandnum (- tilt) tilt) (car bpt)))
(getrandnum (cadr bpt) (+ h (cadr bpt)))
)
)
(grass bpt top)
)
)
(princ)
)
(c:gr)

Match Properties (Grrr Dialog box version)


; My Match Properties - Created by Grrr
; Saved from: https://www.theswamp.org/index.php?topic=52951.0

(defun C:MMP ( / tgassoc tgswitch *error* dcl des dch dcf tmp L SS tmpL i o )

; Toggle associator - connect toggle value (0 or 1) with symbol value (nil or T):
(defun tgassoc ( keyorval ) (cadr (assoc keyorval '((nil "0")(T "1")("0" nil)("1" T)))) ) ; Grrr

; Toggle switcher - switch toggle's value
(defun tgswitch ( key ) (set_tile key (cadr (assoc (get_tile key) '(("0" "1") ("1" "0")))))) ; Grrr

(defun *error* ( msg )
(and (>\"; fixed_width = true; width = 2; }"
" }"
" : row "
" { : text { label = \"Destination objects\"; }"
" : button { key = \"db\"; label = \">>\"; fixed_width = true; width = 2; }"
" }"
" }"
" : spacer { height = 1; }"
(if L
(strcat
" : column"
" { children_fixed_width = true; children_alignment = left;"
" : text { label = \"Properties To Match\"; } spacer;"
(apply 'strcat (mapcar (function (lambda (x) (strcat ": toggle { label = \"" (car x) "\"; key = \"" (car x) "\"; value = 1; }"))) L))
" spacer;"
" : button { label = \"Switch Toggles\"; key = \"Switch\"; mnemonic = \"t\"; }"
" spacer;"
" }"
); strcat
" : text { label = \"Source object not specified!\"; alignment = centered; }"
); if L
" : spacer { height = 1; }"
" ok_cancel; : text { key = \"error\"; }"
"}"
); list
); vl-every
(not (setq des (close des))) (< 0 (setq dch (load_dialog dcl)))
); and
); not
(princ "\nUnable to write or load the DCL file.") (setq dcf 0)
)
( (not (new_dialog "MyMatchProps" dch)) (princ "\nUnable to display the dialog") (setq dcf 0) )
(T
(if tmpL (mapcar (function (lambda (x) (set_tile (car x) (cdr x)))) tmpL)) ; remember (restore) chosen toggles between sessions.
(vl-every (function (lambda (x) (action_tile (car x) (strcat "(done_dialog " (itoa (cadr x)) ")")))) '(("sb" 2) ("db" 3))) ; button actions
(action_tile "Switch"
(vl-prin1-to-string
'(progn
(mapcar (function (lambda (x) (tgswitch x))) (mapcar 'car L))
(setq tmpL (mapcar (function (lambda (x) (cons x (get_tile x)))) (mapcar 'car L)))
); progn
); vl-prin1-to-string
); action_tile
(if L
(vl-every ; toggle actions
(function
(lambda (x)
(action_tile (car x)
(vl-prin1-to-string
'(cond
( (assoc $key tmpL) (setq tmpL (subst (cons $key $value) (assoc $key tmpL) tmpL)) )
( (setq tmpL (cons (cons $key $value) tmpL)) )
); cond
); vl-prin1-to-string
); action_tile
); lambda
); function
L
); vl-every
); if L
(action_tile "accept"
(vl-prin1-to-string
'(cond
( (not L) (set_tile "error" "Check the above message - Grrr.") )
( (not SS) (set_tile "error" "Destination objects not specified!") )
( (setq L (mapcar (function (lambda (x) (append x (list (get_tile (car x)))))) L)) ; end result of L
(done_dialog 1)
)
); cond
); vl-prin1-to-string
); action_tile
(setq dcf (start_dialog))
); T
); cond
(cond
( (= 2 dcf)
(and
(setq tmp
(
(lambda (x / p)
(setvar 'errno 0)
(while (/= 52 (getvar 'errno)) (setq p (car (entsel "\nSelect Source Object : ")))
(cond ( (= 7 (getvar 'errno)) (princ "\nMissed, try again!") (setvar 'errno 0) )
(p (setq p (vlax-ename->vla-object p)) (setvar 'errno 52) )
); cond
); while
p
); lambda
nil
)
); setq tmp
(setq L ; I care about only this list here
(apply 'append
(mapcar (function (lambda (x) (if (vlax-property-available-p tmp x) (list (list x (vlax-get tmp x))))))
'("Color" "Layer" "LineType" "LinetypeScale" "Lineweight"
"EntityTransparency" "Material" "Rotation" "TextString" "StyleName" "Width" "Height"
"AttachmentPoint" "BackgroundFill" "LineSpacingDistance" "LineSpacingFactor" "LineSpacingStyle"
"XEffectiveScaleFactor" "XScaleFactor" "YEffectiveScaleFactor" "YScaleFactor" "ZEffectiveScaleFactor" "ZScaleFactor"
); list
); mapcar
); apply 'append
); setq L
); and
); (= 2 dcf)
( (= 3 dcf) (and (princ "\nSelect Destination Objects: ") (setq tmp (ssget "_:L")) (setq SS tmp) ) ); (= 3 dcf)
); cond
); while
(/= 1 dcf)
); progn
(princ "\nUser cancelled the dialog.")
)
( (and L SS)
(setq L (vl-remove-if (function (lambda (x) (not (tgassoc (caddr x))))) L))
(repeat (setq i (sslength SS))
(and (setq o (vlax-ename->vla-object (ssname SS (setq i (1- i))))) (vlax-write-enabled-p o)
(mapcar
(function
(lambda (x)
(and (vlax-property-available-p o (car x)) (vl-catch-all-apply 'vlax-put (list o (car x) (cadr x))))
); lambda
); function
L
); mapcar
); and
); repeat
; (alert (apply 'strcat (mapcar '(lambda (x) (strcat "\n" (vl-prin1-to-string x))) L))) ; check
; (alert (apply 'strcat (mapcar '(lambda (x) (strcat "\n" (vl-prin1-to-string x))) tmpL))) ; check
); T
); cond
(*error* nil) (princ)
);
(c:mmp)

Delete Hatches, Solids and Wipeouts in Blocks (Created by Tharwat)


;;; Delete Hatches, Solids and Wipeouts in Blocks (Created by Tharwat)
;;; Saved from: https://www.theswamp.org/index.php?topic=47212.0

(defun c:dsb (/ doc)
(vlax-for bks (vla-get-blocks (setq
doc (vla-get-ActiveDocument (vlax-get-acad-object))
)
)
(if (and (eq :vlax-false (vla-get-islayout bks))
(eq :vlax-false (vla-get-isXref bks))
)
(vlax-for obj bks
(if (and (wcmatch (vla-get-objectname obj)
"AcDbSolid,AcDbHatch,AcDbWipeout"
)
(vlax-write-enabled-p obj)
)
(vla-delete obj)
)
)
)
)
(vla-regen doc AcAllViewports)
(princ)
)(vl-load-com)
(c:dsb)

Standard ‘Measure’ command however centering the divisions along the selected object


(defun c:GetBlkName (/ ent)
(vl-load-com)
(cond
((and
(setq ent (car (entsel "\nSelect Block Entity: ")))
(eq (cdr (assoc 0 (entget ent))) "INSERT")
(princ (strcat "Block Name:"
(vla-get-effectivename
(vlax-ename->vla-object ent)))))
)))

;;-------------------=={ Centered Measure }==-----------------;;
;; ;;
;; Emulates the behaviour of the standard 'Measure' command ;;
;; however centering the divisions along the selected object ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Slightly modified by Igal Averbuh 2017
(defun c:cm ( / *error* _StartUndo _EndUndo _SelectIf _IsCurveObject acdoc al bl d0 di en mx nm pt )

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

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

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

(defun _SelectIf ( msg pred func / sel ) (setq pred (eval pred))
(while
(progn (setvar 'ERRNO 0) (setq sel (car (func msg)))
(cond
( (= 7 (getvar 'ERRNO))
(princ "\nMissed, Try again.")
)
( (eq 'ENAME (type sel))
(if (and pred (not (pred sel)))
(princ "\nInvalid Object Selected.")
)
)
)
)
)
sel
)

(defun _IsCurveObject ( entity / param )
(and
(not
(vl-catch-all-error-p
(setq param
(vl-catch-all-apply 'vlax-curve-getendparam (list entity))
)
)
)
param
)
)

(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
nm (trans '(0. 0. 1.) 1 0 t)
)
(if (setq en (_SelectIf "\nSelect Object to Measure: " '_isCurveObject entsel))
(progn
(initget 7 "Block")
(setq di (getdist "\nSpecify length of segment or [Block]: "))

(if (eq "Block" di)

(progn

(c:GetBlkName)

(while

(progn (setq bl (getstring t "\nEnter name of block to insert: "))
(cond
( (not (snvalid bl))
(princ "\nInvalid block name.")
)
( (not (tblsearch "BLOCK" bl))
(princ (strcat "\nCannot find block \"" bl "\"."))
)
)
)
)
(initget "Yes No")
(setq al (not (eq "No" (getkword "\nAlign block with object? [Yes/No] : "))))
(initget 7)
(setq di (getdist "\nSpecify length of segment: "))
)
)
(setq mx (vlax-curve-getdistatparam en (vlax-curve-getendparam en))
d0 (- (/ (- mx (* di (fix (/ mx di)))) 2.) di)
)
(_StartUndo acdoc)
(while (and (<= (setq d0 (+ d0 di)) mx) (setq pt (vlax-curve-getpointatdist en d0)))
(if bl
(entmakex
(list
(cons 0 "INSERT")
(cons 2 bl)
(cons 10 (trans pt 0 nm))
(cons 50
(if al
(angle '(0. 0. 0.)
(trans
(vlax-curve-getfirstderiv en (vlax-curve-getparamatpoint en pt)) 0 nm
)
)
0.
)
)
(cons 210 nm)
)
)
(entmakex (list (cons 0 "POINT") (cons 10 pt)))
)
)
(_EndUndo acdoc)
)
(princ "\n*Cancel*")
)
(princ)
)
(vl-load-com) (princ)

;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;;
(c:cm)

Measure LINEs, SPLINEs, LWPOLYLINEs and POLYLINEs by user selected aligned Block


;;; Measure LINEs, SPLINEs, LWPOLYLINEs and POLYLINEs by user selected aligned Block
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-routine-using-the-measure-command/td-p/5562007

(defun c:meb (/ blk ss l name)
; TharwaT 04. 04. 2011
(if
(and (setq blk (entsel "\nSelect Block:"))
(princ "\nSelect Objects to Measure: ")
(setq ss (ssget "_:L" '((0 . "LINE,SPLINE,LWPOLYLINE,POLYLINE"))))
(setq l (getdist "\nDistance between Blocks :"))
)
(progn
(setq name (cdr (assoc 2 (entget (car blk)))))
((lambda (i / ss1)
(while
(setq ss1 (ssname ss (setq i (1+ i))))
(command "_.measure" ss1 "Block" name "_Y" l)
)
)
-1
)
)
(princ)
)
(princ)
)
(c:meb)

Draw line from a point perpendicular to a nearest segment in polyline (Ronjonp routine)


;;; Draw line from a point perpendicular to a nearest segment in polyline (Ronjonp routine)
;;; Saved from: https://www.theswamp.org/index.php?topic=1891.0

(Defun C:dp (/ SA SB SNP OM OS PT1 PT2)
;draws lines perpendicular from a starting point
(setvar "cmdecho" 0)
(setq
SA (getvar "snapang")
SB (getvar "snapbase")
SNP (getvar "snapmode")
OM (getvar "orthomode")
OS (getvar "osmode")
PT1 (osnap (getpoint
"\nPick point on line to draw perpendicular from: "
)
"nea"
)
)
(setvar "osmode" 0)
(setq PT2 (osnap PT1 "end"))
(if (equal PT1 PT2)
(setq PT2 (osnap PT1 "MID"))
)
(command ".snap" "r" PT1 PT2)
(setvar "snapmode" 0)
(setvar "orthomode" 1)
(prompt "\nto point:")
(command ".pline" PT1 pause "")
(setvar "snapang" SA)
(setvar "snapbase" SB)
(setvar "snapmode" SNP)
(setvar "orthomode" OM)
(setvar "osmode" OS)
(setvar "cmdecho" 1)
(princ)
) ; end
(c:dp)

BeekeeCZ Add Sq.cm simbol to the end of text and change text style to apropriative one.


;;; Add Sq.cm simbol to the end of text and change text style to apropriative one.
;;; Created by BeekeeCZ 2017
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/double-selection-issue/td-p/6980727

(defun c:cmt (/ ss ots i ed tx)

(if (and (setq ss (ssget '((0 . "TEXT"))))
(setq ots (getvar 'TEXTSTYLE))
(or (tblsearch "STYLE" "igal")
(command "STYLE" "igal" "arial.ttf" "" "" "" "" "")
(setvar 'TEXTSTYLE ots))
)
(repeat (setq i (sslength ss))
(setq ed (entget (ssname ss (setq i (1- i)))))
(entmod (append ed
(list (cons 1 (strcat (setq tx (cdr (assoc 1 ed)))
(if (wcmatch tx "* cm\\U+00B2")
""
" cm\\U+00B2")))
(cons 7 "igal"))))))
(princ)
)

(c:cmt)