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)

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


;;; Add Sq.m 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:smt (/ 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 "* m\\U+00B2")
""
" m\\U+00B2")))
(cons 7 "igal"))))))
(princ)
)

(c:smt)

Change width to all segments in a selection of polylines


;; Polyline Width - Lee Mac
;; Applies a given constant width to all segments in a selection of polylines.

(defun c:pw ( / *error* idx sel wid )

(defun *error* ( msg )
(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 "\nSelect polylines: " '("_:L" ((0 . "LWPOLYLINE,POLYLINE")))))

;(setq sel (ssget "X" (list '(0 . "LWPOLYLINE"))))

(progn
(initget 4)
;(setq wid 0.0)
(setq wid (getdist "\nEnter New Width: "))
(repeat (setq idx (sslength sel))
(vla-put-constantwidth (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) wid)
)
)
)
(*error* nil)
(princ)
)

;; 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) (princ)
(c:pw)

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.
;;; Combined from existing routines and deeply modified by Igal Averbuh 2017
(defun C:Cst (/ entities len count ent ent_data ent_name new_style_name)

(princ "\nSelect text :")
(setq entities (ssget '((0 . "TEXT")))
len (sslength entities)
count 0
);setq
(command "STYLE" "igal" "arial.ttf" "" "" "" "" "")
(while (< count len)
(setq ent (ssname entities count)
ent_data (entget ent)
ent_name (cdr (assoc 7 ent_data))
);setq

(setq new_style_name (cons 7 "igal"))
(setq ent_data (subst new_style_name (assoc 7 ent_data) ent_data))
(entmod ent_data)

(setq count (+ count 1))
);while

(princ)

);defun

(defun c:smt1 (/ entdata btxt ntxt bltxt)

(while (setq bltxt (nentsel "\nSelect text to add cm²: "))

(setq entdata (entget (car bltxt))
btxt (cdr (assoc 1 entdata))
ntxt (strcat btxt " cm²")
);_setq
(entmod (subst (cons 1 ntxt)(assoc 1 entdata) entdata))
(entupd (cdr (assoc -1 entdata)))

);_while
);_defun

(defun c:cmt() ;Main function
(c:cst)
(c:smt1)

)

(c:cmt)

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


;;; Add Sq.m simbol to the end of text and change text style to apropriative one.
;;; Combined from existing routines and deeply modified by Igal Averbuh 2017

(defun C:Sst (/ entities len count ent ent_data ent_name new_style_name)

(princ "\nSelect text :")
(setq entities (ssget '((0 . "TEXT")))
len (sslength entities)
count 0
);setq
(command "STYLE" "igal" "arial.ttf" "" "" "" "" "")
(while (< count len)
(setq ent (ssname entities count)
ent_data (entget ent)
ent_name (cdr (assoc 7 ent_data))
);setq

(setq new_style_name (cons 7 "igal"))
(setq ent_data (subst new_style_name (assoc 7 ent_data) ent_data))
(entmod ent_data)

(setq count (+ count 1))
);while

(princ)

);defun

(defun c:smt1 (/ entdata btxt ntxt bltxt)

(while (setq bltxt (nentsel "\nSelect text to add m²: "))

(setq entdata (entget (car bltxt))
btxt (cdr (assoc 1 entdata))
ntxt (strcat btxt " m²")
);_setq
(entmod (subst (cons 1 ntxt)(assoc 1 entdata) entdata))
(entupd (cdr (assoc -1 entdata)))

);_while
);_defun

(defun c:smt() ;Main function
(c:sst)
(c:smt1)

)

(c:smt)