Multiline Fillet with increment fillet Radius and option to “Unexplode” connected lines to Polylines


;;; MultiLine Fillet with increment fillet Radius and option to "Unexplode" conected lines to Polylines
;;; Saved from: http://forums.augi.com/showthread.php?44929-Looking-for-a-routine-for-Multiple-Fillet
;;; Combined and slightly modified by Igal Averbuh 2017

;(princ "\nTo Unexplode Polilines use UP function")
;;; Unexplode Polilines
;;; 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:lio)
(while
(princ "\nSelect Polylines to Unexlode")
(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

;;; Helper function to get the point from pt1 perp to entity picked at point pt2
(defun GetPerpPoint (pt1 pt2 /)
(setvar "LASTPOINT" pt1)
(osnap pt2 "_perp")
) ;_ end of defun

;;; Helper function to get the distance from pt1 perp to entity picked at point pt2
(defun GetPerpDist (pt1 pt2 /)
(distance pt1 (GetPerpPoint pt1 pt2))
) ;_ end of defun

(setq MFillet:Inc "Yes") ;Remember increment fillet

;;; Fillet multiple lines by selecting with fences
(defun c:MF1 (/ ss1 ss2 n m en1 en2 pt1 pt2 ptlast rad rad1 cmd)
(setq cmd (getvar "CMDECHO")) ;Get value of CMDECHO
(setvar "CMDECHO" 0) ;Don't show prompts on command line
(command "_.UNDO" "_BEgin")
(setq rad (getvar "FILLETRAD")) ;Get the normal fillet radius
(while (/= (type pt1) 'List)
(princ (strcat "\nCurrent settings: Raduis = "
(rtos rad)
", Increment Fillet = "
MFillet:Inc
"\n"
) ;_ end of strcat
) ;_ end of princ
(initget "Radius Increment") ;Setup for keywords
(setq pt1 (getpoint "Select by fence-line 1st set of LINES [Radius/Increment]: ")) ;Get 1st point
(cond
((and (= pt1 "Radius")
(setq rad1 (getDist (strcat "New Radius : ")))
) ;_ end of and
(setq rad rad1)
)
((= pt1 "Increment")
(initget "Yes No")
(if (setq rad1 (getkword (strcat "Do you want to increment the radius? [Yes/No] : ")))
(setq MFillet:Inc rad1)
) ;_ end of if
)
) ;_ end of cond
) ;_ end of while
(setq pt2 (getpoint pt1 "2nd point of fence-line: ")
ss1 (ssget "F" (list pt1 pt2))
) ;_ end of setq
(setq pt1 (getpoint "Select by fence-line 2nd set of LINES: ")
pt2 (getpoint pt1 "2nd point of fence-line: ")
ss2 (ssget "F" (list pt1 pt2))
) ;_ end of setq
(setq n 0
m 0
rad1 0.0 ;Initialize the radius to add
) ;_ end of setq
(while (and ss1 ss2 (< n (sslength ss1)) (< m (sslength ss2)))
(setq en1 (ssname ss1 n)
pt1 (cadr (cadddr (car (ssnamex ss1 n))))
en2 (ssname ss2 m)
pt2 (cadr (cadddr (car (ssnamex ss2 m))))
) ;_ end of setq
(if (and ptlast (= MFillet:Inc "Yes"))
(setq rad1 (+ rad1 (GetPerpDist ptlast pt1)))
) ;_ end of if
(setvar "FILLETRAD" (+ rad rad1))
(command "_.FILLET" (list en1 pt1) (list en2 pt2))
(setq n (1+ n)
m (1+ m)
ptlast pt1
) ;_ end of setq
) ;_ end of while
(setvar "FILLETRAD" rad) ;Restore previous radius
(command "_.UNDO" "_End")
(setvar "CMDECHO" cmd) ;Restore prompts on command line
(princ)
) ;_ end of defun

(defun c:mf ( / )
(c:lio)
(c:mf1)
;(c:up)
(c:luo)
)
(c:mf)
(alert "\nTo Unexplode Polylines use UP function\nPress Esc button twice to interupt UP function\nAfter Polylines unexploding use LUO function to UnIsolate Layers ")

Advertisements

Change Color of All Layers to user defined color with change color Color of ALL entities in the drawing to ByLayer


;;; Change Color of All Layers to user defined color with change color Color of ALL entities in the drawing to ByLayer
;;; Main routine Created by Igal Averbuh 2017
;;; Subroutine AllColorBylayer.lsp created by Kent Cooper

(vl-load-com)
;; AllColorBylayer.lsp [command name: ACB]
;; To change the Color of ALL entities in the drawing, including those nested in
;; Block definitions [but not Xrefs] and Dimension/Leader parts, to ByLayer.
;; Kent Cooper, 27 February 2014, expanding on some elements by p_mcknight

(defun C:ACB ; = All to Color Bylayer
(/ cb ent obj blk subent)
(defun cb () ; = force Color(s) to Bylayer
(setq obj (vlax-ename->vla-object ent))
(vla-put-color obj 256); ByLayer
(if (wcmatch (vla-get-ObjectName obj) "*Dimension,*Leader")
(foreach prop '(DimensionLineColor ExtensionLineColor TextColor)
;; not all such entity types have all 3 properties, but all have at least one
(if (vlax-property-available-p obj prop)
(vlax-put obj prop 256); ByLayer
); if
); foreach
); if
); defun -- cb
;; Top-level entities:
(setq ent (entnext))
(while ent
(cb)
(setq ent (entnext ent))
); while
;; Nested entities in this drawing's Block definitions:
(setq blk (tblnext "block" t))
(while blk
(if (= (logand 20 (cdr (assoc 70 blk))) 0); not an Xref [4] or Xref-dependent [16]
(progn
(setq ent (cdr (assoc -2 blk)))
(while ent
(cb)
(setq ent (entnext ent))
); while
); progn
); if
(setq blk (tblnext "block"))
); while

(princ)
); defun

(defun c:cch1 (/ c1 c2 )
(vl-load-com)
(setq c2 (getint " What is the new color: "))
(vlax-for layer
(vla-get-Layers
(vla-get-ActiveDocument
(vlax-get-Acad-Object))) (vla-put-Color layer c2))
(prin1)
)

(defun c:cch (/ )
(c:acb)
(c:cch1)
)
;(c:cch)

Convert All RGB color layers to ACI index


;;; Convert All RGB colour layers to ACI index
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?65645-Convert-from-index-colours-to-true-colours
(defun C:LRB ( )
(Color-to-ACIcolor)
; (command "_.Regenall")
(princ)
)
(defun Color-to-ACIcolor (/ txt count *error*)
(defun *error* (msg)
(princ msg)
(mip:layer-status-restore)
(princ)
) ;_ end of defun
(mip:layer-status-save)
(vlax-for Blk (vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
) ;_ end of vla-get-blocks
(setq count 0)
(grtext -1
(setq txt
(strcat "Inspecting objects: "
(vla-get-name Blk)
)
)
) ;_ end of grtext
(if (= (vla-get-isxref Blk) :vlax-false)
(progn
(vlax-for Obj Blk
(setq count (1+ count))
(if (zerop (rem count 10))
(grtext -1 (strcat txt " : " (itoa count)))
)
(if (and (vlax-write-enabled-p Obj)
(vlax-property-available-p Obj 'Color)
)
(vla-put-color Obj (vla-get-color Obj))
)
) ;_ end of vlax-for
) ;_ end of progn
) ;_ end of if
) ;_ end of vlax-for
(vlax-for Lay (vla-get-layers
(vla-get-activedocument (vlax-get-acad-object))
)
(vla-put-color Lay (vla-get-color Lay))
)
(mip:layer-status-restore)
)
(defun mip:layer-status-restore ()
(foreach item *PD_LAYER_LST*
(if (not (vlax-erased-p (car item)))
(vl-catch-all-apply
'(lambda ()
(vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
(vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of if
) ;_ end of foreach
(setq *PD_LAYER_LST* nil)
) ;_ end of defun

(defun mip:layer-status-save ()
(setq *PD_LAYER_LST* nil)
(vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
(setq *PD_LAYER_LST* (cons (list item
(cons "freeze" (vla-get-freeze item))
(cons "lock" (vla-get-lock item))
) ;_ end of cons
*PD_LAYER_LST*
) ;_ end of cons
) ;_ end of setq
(vla-put-lock item :vlax-false)
(if (= (vla-get-freeze item) :vlax-true)
(vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false))))
) ;_ end of vlax-for
) ;_ end of defun
(princ)
(c:lrb)

Convert selected ACI color layers to RGB index


;;; Convert selected ACI colour layers to RGB index
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?65645-Convert-from-index-colours-to-true-colours
(defun C:LRC ( / lay truecol aci R G B lm i)
(vl-load-com)
(setq lm (getstring "\nLayer(s) to convert to truecolor (*=all, layer name or mask) : ") i 0)
(if (= lm "") (setq lm "*"))
(vlax-for lay (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
(if (wcmatch (vla-get-name lay) lm)(progn
(setq truecol (vla-get-truecolor lay))
(if (= (vla-get-ColorMethod truecol) acColorMethodByACI) ; ACI?
(progn
(setq aci (vla-get-ColorIndex truecol))
(vla-put-ColorMethod truecol acColorMethodByRGB)
(vla-put-ColorIndex truecol aci)
(setq R (vla-get-red truecol))
(setq G (vla-get-green truecol))
(setq B (vla-get-blue truecol))
(vla-setRGB truecol R G B)
(vla-put-truecolor lay truecol)
(setq i (1+ i))
)
)
))
) ; vlax
(princ (strcat "\n" (itoa i) " layer(s) converted."))
(princ)
)
(c:lrc)

Selection of block references according to attribute labels and their specific values


;; Selection of block references according to attribute labels and their specific values
;; Saved from:
;; http://cadxp.com/index.php?/topic/37573-faire-une-selection-dun-bloc-en-fonction-de-deux-de-ses-attributs/page__pid__207342#entry207342
;;
;; Routine by VDH-Bruno le: 28/05/2013
;; ======================================================================

(defun c:fa (/ lstTagAtt tagAtt doc ss1 ss2 inclu-p inputval)
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))
ss2 (ssadd)
)

(vlax-for b (vla-get-Blocks doc)
(if (and (= (vla-get-IsLayout B) :vlax-false)
(= (vla-get-IsXref B) :vlax-false)
(not (wcmatch (vla-get-Name B) "*|*"))
)
(vlax-for o b
(and (= (vla-get-ObjectName o) "AcDbAttributeDefinition")
(not (member (setq tagAtt (vla-get-TagString o)) lstTagAtt))
(setq lstTagAtt (cons tagAtt lstTagAtt))
)
)
)
)

(setq
lstTagAtt (listbox

"Attribute Fields/Columns "
"Select the Attribute Fields/Columns to Filter ... "

(mapcar 'cons (setq lstTagAtt (vl-sort lstTagAtt '<)) lstTagAtt)
2
)
)

(defun inputval (l)
(if l
(cons
(cons
(car l)

(getstring (strcat "Value to search for the Fields/Columns " (car l) ": ")

)
)
(inputval (cdr l))
)
)
)

(cond
((setq lstTagAtt (inputval lstTagAtt))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(princ "\nSelect the Blocks or : " )

(or (ssget (list '(0 . "INSERT") '(66 . 1)))
(ssget "_X" (list '(0 . "INSERT") '(66 . 1)))
)

(defun inclu-p (l1 l2)
(cond ((null l1) t)
((member (car l1) l2) (inclu-p (cdr l1) l2))
(t nil)
)
)

(vlax-for b (setq ss1 (vla-get-ActiveSelectionSet doc))
;; vיrifie que les critטres de filtres liste (Tag .Val) sont compris dans le bloc
(if (inclu-p
lstTagAtt
;; Liste les couples (Tag .Val) de la rיfיrence de bloc
(mapcar
'(lambda (x) (cons (vla-get-TagString x) (vla-get-TextString x)))
(vlax-invoke b 'GetAttributes)
)
)
(ssadd (vlax-vla-object->ename B) ss2)
)
)
(vla-delete ss1)
(sssetfirst nil ss2)
)
)
(princ)
)

(defun str2lst (str sep / pos)
(if (setq pos (vl-string-search sep str))
(cons (substr str 1 pos)
(str2lst (substr str (+ (strlen sep) pos 1)) sep)
)
(list str)
)
)

;

(defun ListBox (title msg keylab flag / tmp file dcl_id choice)
(setq tmp (vl-filename-mktemp "tmp.dcl")
file (open tmp "w")
)
(write-line
(strcat "ListBox:dialog{label=\"" title "\";")
file
)
(if (and msg (/= msg ""))
(write-line (strcat ":text{label=\"" msg "\";}") file)
)
(write-line
(cond
((= 0 flag) "spacer;:popup_list{key=\"lst\";")
((= 1 flag) "spacer;:list_box{key=\"lst\";")
(T "spacer;:list_box{key=\"lst\";multiple_select=true;")
)
file
)
(write-line "}spacer;ok_cancel;}" file)
(close file)
(setq dcl_id (load_dialog tmp))
(if (not (new_dialog "ListBox" dcl_id))
(exit)
)
(start_list "lst")
(mapcar 'add_list (mapcar 'cdr keylab))
(end_list)
(action_tile
"accept"
"(or (= (get_tile \"lst\") \"\")
(if (= 2 flag) (progn
(foreach n (str2lst (get_tile \"lst\") \" \")
(setq choice (cons (nth (atoi n) (mapcar 'car keylab)) choice)))
(setq choice (reverse choice)))
(setq choice (nth (atoi (get_tile \"lst\")) (mapcar 'car keylab)))))
(done_dialog)"
)
(start_dialog)
(unload_dialog dcl_id)
(vl-file-delete tmp)
choice
)

(c:fa)

Select all blocks with selected attribute


;;; Select all blocks with selected attribute
;;; Saved from: https://forums.autodesk.com/t5/autocad-forum/select-through-attribute-value/td-p/2227193

(defun c:fa (/ att elst tag val ss1 ss2 n ent)
(and
(setq att (car (nentsel "\nSelect source attribute: ")))
(setq elst (entget att))
(setq tag (cdr (assoc 2 elst))
val (cdr (assoc 1 elst))
ss2 (ssadd)
)
(setq ss1 (ssget "_X"
(list '(0 . "INSERT")
(assoc 2 (entget (cdr (assoc 330 elst))))
)
)
)
(repeat (setq n (sslength ss1))
(setq ent (ssname ss1 (setq n (1- n)))
att (entnext ent)
)
(while (= (cdr (assoc 0 (setq elst (entget att)))) "ATTRIB")
(if (and (= (cdr (assoc 2 elst)) tag)
(= (cdr (assoc 1 elst)) val)
)
(ssadd ent ss2)
)
(setq att (entnext att))
)
)
(sssetfirst nil ss2)
)
(princ)
)
(c:fa)

Draw line and a text with layer name and description for each layer (Layer Legend)


;;; Draw line and a text with layer name and description for each layer (Layer Legend)
;;; Created by HasanCAD
;;; Saved from: https://www.theswamp.org/index.php?topic=53481.0

(defun c:LLD () (c:LayerLegend))

(defun c:LayerLegend ( / df i ln p1 pt sp ) ;; Lee Mac 2011
(if
(and
(setq pt (getpoint "\nSpecify Point for Legend: "))
(setq ln (* 100 (getvar 'TEXTSIZE))) ;(getdist "\nSpecify Length of Lines: " pt))
(setq pt (trans pt 1 0))
(setq i -1)
(setq sp (* 1.5 (getvar 'TEXTSIZE)))
)
(while (setq df (tblnext "LAYER" (null df)))
(setq ent (vlax-ename->vla-object (tblobjname "LAYER" (cdr (assoc 2 df)))))
(setq dsc (vlax-get-property ent 'Description))
(setq nm (vlax-get-property ent 'name))
(entmakex (list
(cons 0 "LINE")
(cons 8 (cdr (assoc 2 df)))
(cons 6 "ByLayer")
(cons 62 256)
(cons 10
(setq p1 (polar pt (* 1.5 pi) (* (setq i (1+ i)) sp)))
)
(cons 11 (polar p1 0. ln))
(cons 370 -1)
)
)

(entmakex (list (cons 0 "TEXT") ;***
(cons 1 (strcat (cdr (assoc 2 df)) " : " dsc)) ;* (the string itself)
(cons 6 "BYLAYER") ; Linetype name
(cons 7 (getvar 'TEXTSTYLE)) ;* Text style name, defaults to STANDARD, not current
(cons 8 (cdr (assoc 2 df))) ; layer
(cons 10 p1) ;* First alignment point (in OCS)
(cons 11 p1) ;* Second alignment point (in OCS)
(cons 39 0.0) ; Thickness (optional; default = 0)
(cons 40 (getvar 'TEXTSIZE)) ;* Text height
(cons 41 1.0) ; Relative X scale factor, Width Factor, defaults to 1.0
(cons 62 256) ; color
(cons 71 0) ; Text generation flags
(cons 72 0) ; Horizontal text justification type
(cons 73 1) ; Vertical text justification type
(cons 210 (list 0.0 0.0 1.0))
(cons 370 -1)
))
) )
(princ)
)
(c:lld)

Rotate selected side of polyline to zero


;;; Rotate selected side of polyline to zero
;;; Created by phanaem
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/rotate-a-selected-side-of-a-polyline-to-zero-degrees-in-autolisp/td-p/7563715
;;; It is important where you make the selection.
;;; The nearest vertex is the base point of the rotation. The other vertex of the clicked segment is the reference point
(defun c:pz ( / e p a p1 p2)
(if
(setq e (entsel "\nSelect polyline segment to rotate to zero: "))
(progn
(setq p (cadr e)
e (car e)
a (vlax-curve-getparamatpoint e (vlax-curve-getclosestpointto e p))
p1 (vlax-curve-getpointatparam e (if (< (- a (fix a)) 0.5) (fix a) (1+ (fix a))))
p2 (vlax-curve-getpointatparam e (if (< (- a (fix a)) 0.5) (1+ (fix a)) (fix a)))
)
(command "_rotate" e "" "_non" p1 "_r" "_non" p1 "_non" p2 0.0)
)
)
(princ)
)
(c:pz)

Select Hatches with Equal, Smaller or Larger Area than specified by user


;; Hatch Select Criteria - HSC
;; Select Hatches with Equal, Smaller or Larger Area than specified by user
;; Created by ronjonp
;; Saved from https://www.theswamp.org/index.php?topic=53620.0

(defun c:hsc (/ a b fuzz e o s)
(sssetfirst nil nil)
(or *global* (setq *global* "Equal"))
;; Change this number to suit for equality check
(setq fuzz 0.1)
(if
(and
(setq e (car (entsel "\nPick a hatch to get area: ")))
(= 'real (type (setq a (vl-catch-all-apply 'vla-get-area (list (vlax-ename->vla-object e))))))
(not (initget "Equal Smaller Larger"))
(or (setq *global* (getkword (strcat "\nSpecify [Equal/Smaller/Larger] : ")))
*global*
)
(setq s (ssget '((0 . "hatch"))))
)
(progn
(foreach x (vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
(setq o (eval (cdr (assoc *global* '(("Equal" . equal) ("Smaller" . ))))))
(if (= 'real
(type (setq b (vl-catch-all-apply 'vla-get-area (list (vlax-ename->vla-object x)))))
)
(if (null (cond ((= o equal) (o b a fuzz))
((and (o b a) (not (equal b a fuzz))))
)
)
(ssdel x s)
)
(ssdel x s)
)
)
(sssetfirst nil s)
)
)
(princ)
)
(vl-load-com)
(c:hsc)

Create closed area Hatch Ceiling 30x120cm. already drawn by polyline with option to offset this polyline


;;; Create closed area Hatch Ceiling 30x120cm. already drawn by polyline with option to offset this polyline
;;; Created by Igal Averbuh 2017

(defun c:phx ( / hpn )
(setq hpn (getvar 'hpname))

(setvar 'hpname "net")
(setvar "osmode" 167)
(setvar "HPORIGINMODE" 1) ; 1 - Uses the bottom-left corner of the rectangular extents of the hatch boundaries

; 2 - Uses the bottom-right corner of the rectangular extents of the hatch boundaries

; 3 - Uses the top-right corner of the rectangular extents of the hatch boundaries

; 4 - Uses the top-left corner of the rectangular extents of the hatch boundaries

; 5 - Uses the center of the rectangular extents of the hatch boundaries

(command "_.pline")
(while (< 0 (getvar 'cmdactive)) (command "\\"))

(setvar 'OFFSETDIST
(cond ((getdist (strcat "\nSpecify offset distance: If zero take 0.001 : ")))
((getvar 'OFFSETDIST))
)
)

(setq ent (entlast))
(command "_.offset" "_E" "_Y" (getvar 'OFFSETDIST) ent pause "")

(command "_.offset" "_E" "_N" "" "")

(COMMAND "-hatch" "p" "ANSI31" "240" "225" "s" "l" "" "")

(while (< 0 (getvar 'cmdactive)) (command ""))
(setvar "HPORIGINMODE" 0)
(princ)
(command "_.change" "L" "" "P" "C" "Bylayer" "")
)

(defun c:p30 ( /)
(c:phx)

)
(c:p30)