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)

Advertisements

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)

Create closed area Hatch Ceiling 60x60cm. already drawn by polyline with option to offset this polyline


;;; Create closed area Hatch Ceiling 60x60cm. 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

;(setq sc (getdist "\nSet Initial Hatch Scale: "))
(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" "net" "480" "0" "s" "l" "" "")

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

(defun c:p60 ( /)
(c:phx)

)
(c:p60)

Draw ceiling with 60×60 spacing


;; Fill ceiling with 60x60 spacing
;; Author: Fools, 2017.8.26
;; Saved from: https://www.theswamp.org/index.php?topic=53367.0
;; Slightly modified by Igal Averbuh 2017 (added scaling to net hatch for 60x60 spacing)

(DEFUN c:Cel(/ ANG ANGS E PT PTS SPACING UCSANG UCSPT)
(setq spacing 600.)
(SETQ ucspt (GETVAR 'ucsorg))
(setq ucsang (angle (GETVAR 'ucsorg) (GETVAR 'ucsxdir)))
(IF (SETQ e (CAR (ENTSEL "\nSelect a pline boundary : ")))
(PROGN (SETQ pts (MAPCAR 'CDR (VL-REMOVE-IF (FUNCTION (LAMBDA (x) (/= 10 (CAR x)))) (ENTGET e))))
;;Sort by yx , get a point that contains the smallest Y coordinate and relatively small X coordinate
(SETQ pt (CAR (VL-SORT pts
'(LAMBDA (p1 p2)
(COND ((AND (EQUAL (CADR p1) (CADR p2) 1e-3) (< (CAR p1) (CAR p2))) T)
((< (CADR p1) (CADR p2)) T)
(T nil)
)
)
)
)
)
;;Get the angle of each edge in a polyline
(SETQ angs (MAPCAR 'ANGLE pts (APPEND (CDR pts) (LIST (CAR pts)))))
(SETQ angs (MAPCAR '(LAMBDA (x) (REM x (* 0.5 PI))) angs))
;;Return the angle that appears most frequently
(SETQ ang (F_MaxNumAng angs))
(F_SetUcs pt ang)
(COMMAND ".hatch" "net" (/ (* spacing 600.) 1000) 0 e "")
(COMMAND "-hatchedit" "l" "p" "" 480 "")
)
)
;;Restore original ucs
(F_SetUcs ucspt ucsang)
(princ)
)

;;Return the angle that appears most frequently
;;If each angle is different , return 0.0
(DEFUN F_MaxNumAng (lst / i AngNums LastAng)
(SETQ lst (VL-SORT lst '(LAMBDA (e1 e2) ( (CAR e1) (CAR e2)))))
(IF (<= (CAAR AngNums) 2)
0.0
(CADAR AngNums)
)
)

;;Set Ucs
(DEFUN F_SetUcs (pt ang)
(COMMAND ".ucs"
"3"
"non"
(TRANS pt 0 1)
"non"
(TRANS (POLAR pt ang 100.) 0 1)
"non"
(TRANS (POLAR pt (+ ang (* 0.5 PI)) 100.) 0 1)
)
)

(princ "\n Type Cel to start .")
(princ)
(c:cel)

Draw ceiling with 30x.. spacing


;; Fill ceiling with 30x.. spacing
;; Based on Fools, 2017.8.26 approach
;; Saved from: https://www.theswamp.org/index.php?topic=53367.0
;; Slightly modified by Igal Averbuh 2017 (added option for 30x.. spacing)

(DEFUN c:Cem(/ ANG ANGS E PT PTS SPACING UCSANG UCSPT)
(setq spacing 600.)
(SETQ ucspt (GETVAR 'ucsorg))
(setq ucsang (angle (GETVAR 'ucsorg) (GETVAR 'ucsxdir)))
(IF (SETQ e (CAR (ENTSEL "\nSelect a pline boundary : ")))
(PROGN (SETQ pts (MAPCAR 'CDR (VL-REMOVE-IF (FUNCTION (LAMBDA (x) (/= 10 (CAR x)))) (ENTGET e))))
;;Sort by yx , get a point that contains the smallest Y coordinate and relatively small X coordinate
(SETQ pt (CAR (VL-SORT pts
'(LAMBDA (p1 p2)
(COND ((AND (EQUAL (CADR p1) (CADR p2) 1e-3) (< (CAR p1) (CAR p2))) T)
((< (CADR p1) (CADR p2)) T)
(T nil)
)
)
)
)
)
;;Get the angle of each edge in a polyline
(SETQ angs (MAPCAR 'ANGLE pts (APPEND (CDR pts) (LIST (CAR pts)))))
(SETQ angs (MAPCAR '(LAMBDA (x) (REM x (* 0.5 PI))) angs))
;;Return the angle that appears most frequently
(SETQ ang (F_MaxNumAng angs))
(F_SetUcs pt ang)
(COMMAND "-hatch" "p" "ANSI31" "240" "315" "s" e "" "")

)
)
;;Restore original ucs
(F_SetUcs ucspt ucsang)
(princ)
)

;;Return the angle that appears most frequently
;;If each angle is different , return 0.0
(DEFUN F_MaxNumAng (lst / i AngNums LastAng)
(SETQ lst (VL-SORT lst '(LAMBDA (e1 e2) ( (CAR e1) (CAR e2)))))
(IF (<= (CAAR AngNums) 2)
0.0
(CADAR AngNums)
)
)

;;Set Ucs
(DEFUN F_SetUcs (pt ang)
(COMMAND ".ucs"
"3"
"non"
(TRANS pt 0 1)
"non"
(TRANS (POLAR pt ang 100.) 0 1)
"non"
(TRANS (POLAR pt (+ ang (* 0.5 PI)) 100.) 0 1)
)
)

(princ "\n Type Cem to start .")
(princ)
(c:cem)

Insert Block at Intersections


;;------------=={ Insert Block at Intersections }==-----------;;
;; ;;
;; Prompts the user to select or specify a block to be ;;
;; inserted, and make a selection of intersecting objects. ;;
;; Proceeds to insert the specified block at all points of ;;
;; intersection between all objects in the selection. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2012 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/insert-block-at-intersection/m-p/4522675#M315888

(defun c:ins ( / *error* a b bfn blk cmd i j sel spc )

(defun *error* ( msg )
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(while
(progn
(setvar 'errno 0)
(initget "Name Browse Exit")
(setq sel (entsel "\nSelect block to insert [Name/Browse] : "))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (or (null sel) (= "Exit" sel))
nil
)
( (= "Browse" sel)
(if (setq bfn (getfiled "Select Block" (getvar 'dwgprefix) "dwg" 16))
(if (null (tblsearch "block" (setq blk (cadr (fnsplitl bfn)))))
(progn
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.-insert" bfn nil)
(setvar 'cmdecho cmd)
(null (tblsearch "block" blk))
)
)
(princ "\n*Cancel*")
)
)
( (= "Name" sel)
(while
(not
(or (= "" (setq blk (getstring t "\nSpecify block name : ")))
(tblsearch "block" blk)
)
)
(princ "\nBlock not found.")
)
(= "" blk)
)
( (= 'list (type sel))
(if (= "INSERT" (cdr (assoc 0 (entget (car sel)))))
(setq blk (LM:blockname (vlax-ename->vla-object (car sel))))
(princ "\nObject is not a block.")
)
)
)
)
)

(if
(and
(= 'str (type blk))
(tblsearch "block" blk)
(setq sel (ssget))
)
(progn
(setq spc
(vlax-get-property (LM:acdoc)
(if (= 1 (getvar 'cvport))
'paperspace
'modelspace
)
)
)
(LM:startundo (LM:acdoc))
(repeat (setq i (sslength sel))
(setq a (vlax-ename->vla-object (ssname sel (setq i (1- i)))))
(if (vlax-method-applicable-p a 'intersectwith)
(repeat (setq j i)
(setq b (vlax-ename->vla-object (ssname sel (setq j (1- j)))))
(if (vlax-method-applicable-p b 'intersectwith)
(foreach p (LM:intersections a b acextendnone)
(vla-insertblock spc (vlax-3D-point p) blk 1.0 1.0 1.0 0.0)
)
)
)
)
)
(LM:endundo (LM:acdoc))
)
)
(princ)
)

;; Intersections - Lee Mac
;; Returns a list of all points of intersection between two objects
;; obj1,obj2 - VLA-Objects with the intersectwith method applicable
;; mode - acextendoption enum of intersectwith method

(defun LM:intersections ( obj1 obj2 mode / l r )
(setq l (vlax-invoke obj1 'intersectwith obj2 mode))
(repeat (/ (length l) 3)
(setq r (cons (list (car l) (cadr l) (caddr l)) r)
l (cdddr l)
)
)
(reverse r)
)

;; Block Name - Lee Mac
;; Returns the true (effective) name of a supplied block reference

(defun LM:blockname ( obj )
(if (vlax-property-available-p obj 'effectivename)
(defun LM:blockname ( obj ) (vla-get-effectivename obj))
(defun LM:blockname ( obj ) (vla-get-name obj))
)
(LM:blockname obj)
)

;; 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:ins)