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)

Insert Block on Points


;;; Insert Block on Points
;;; Created by rogerio_brazil
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-to-convert-points-to-blocks/td-p/1652793
;;; Slightly modified by Igal Averbuh 2017 (added option to select block on screen)

(defun c:BOP (/ #cmdecho blkname ss scale idx n entname edata)
(command "undo" "begin")
(setq #cmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)

(setq ent (car (entsel "\nSelect Block Entity: ")))
(setq blkname (cdr (assoc 2 (entget ent))))
(eq (cdr (assoc 0 (entget ent))) "INSERT")
(princ (strcat "Block Name:"
(vla-get-effectivename
(vlax-ename->vla-object ent))))

;(setq blkname (getstring "\n Block name : "))
(if (= blkname "")(setq blkname "Block"))
(setq ss (ssget '((0 . "POINT"))))
(if ss
(progn
(setq scale (getreal "\n Block Scale : "))
(if (= scale nil)(setq scale 1))
(setq idx 0)
(setq n (sslength ss))
(repeat n
(setq entname (ssname ss idx))
(setq edata (entget entname))
(entmake (list (cons 0 "INSERT")
(cons 2 blkname)
(assoc 10 edata)
(assoc 8 edata)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
(cons 50 0)
)
)
(entdel entname)
(setq idx (1+ idx))
)
(princ "\n\n Done!")
)
(princ "\n Not point(s) selected(s)!")
)
(setvar "cmdecho" #cmdecho)
(command "undo" "end")
(princ))

Copy Object (block) on Points


;;; Copy Object (block) on points
;;; Created by mdhutchinson
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-point-with-block-object/td-p/2157479
;;; Slightly modified by Igal Averbuh 2017 (added option to select needful points)

(defun c:Rp()
(command "undo" "begin")
(princ "\nSelect Points: ")
(setq ss (ssget '((0 . "POINT"))))
;(setq ss (ssget "x" (list (cons 0 "point"))))
(setq inc 0)
(setq obj (car (entsel "\nSelect an Object to locate at each Selected point: ")))
(setq orgpnt (cdr (assoc '10 (entget obj))))
(while (setq node (ssname ss inc))
(setq topnt (cdr (assoc '10 (entget node))))
(command "copy" obj "" orgpnt topnt)
(setq inc (1+ inc))
)
(princ "\nDone")
(command "undo" "end")
)
;(c:rp)

Copy selected entities and paste it as block in one command


;;--------------------=={ Change Block Base Point }==-------------------;;
;; ;;
;; This program allows the user to change the base point for all ;;
;; block references of a block definition in a drawing. ;;
;; ;;
;; The program offers two commands: ;;
;; ;;
;; ------------------------------------------------------------------ ;;
;; CBP (Change Base Point) ;;
;; ------------------------------------------------------------------ ;;
;; ;;
;; This command will retain the insertion point coordinates for all ;;
;; references of the selected block. Hence visually, the block ;;
;; components will be moved around the insertion point when the ;;
;; base point is changed. ;;
;; ;;
;; ------------------------------------------------------------------ ;;
;; CBPR (Change Base Point Retain Reference Position) ;;
;; ------------------------------------------------------------------ ;;
;; ;;
;; This command will retain the position of the each block reference ;;
;; of the selected block. Hence, each block reference will be moved ;;
;; to retain the visual position when the base point is changed. ;;
;; ;;
;; ------------------------------------------------------------------ ;;
;; ;;
;; Upon issuing a command syntax at the AutoCAD command-line, the ;;
;; program will prompt the user to select a block for which to change ;;
;; the base point. ;;
;; ;;
;; Following a valid selection, the user is then prompted to specify ;;
;; a new base point relative to the selected block. ;;
;; ;;
;; The block definition (and block reference depending on the command ;;
;; used) will then be modified to reflect the new block base point. ;;
;; ;;
;; If the selected block is attributed, an ATTSYNC operation will ;;
;; also be performed to ensure all attributes are in the correct ;;
;; positions relative to the new base point. ;;
;; ;;
;; Finally, the active viewport is regenerated to reflect the changes ;;
;; throughout all references of the block. ;;
;; ;;
;; The program will furthermore perform successfully with rotated & ;;
;; scaled block references, constructed in any UCS plane. ;;
;; ;;
;; ------------------------------------------------------------------ ;;
;; Please Note: ;;
;; ------------------------------------------------------------------ ;;
;; ;;
;; A REGEN is required if the UNDO command is used to undo the ;;
;; operations performed by this program. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.5 - 20-10-2013 ;;
;;----------------------------------------------------------------------;;

;; Retains Insertion Point Coordinates
(defun c:cbp nil (LM:changeblockbasepoint nil))

;; Retains Block Reference Position
(defun c:cbpr nil (LM:changeblockbasepoint t))

;;----------------------------------------------------------------------;;

(defun LM:changeblockbasepoint ( flg / *error* bln cmd ent lck mat nbp vec )

(defun *error* ( msg )
(foreach lay lck (vla-put-lock lay :vlax-true))
(if (= 'int (type cmd)) (setvar 'cmdecho cmd))
(LM:endundo (LM:acdoc))
(if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
(princ (strcat "\nError: " msg))
)
(princ)
)

(while
(progn (setvar 'errno 0) (setq ent (entlast))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (= 'ename (type ent))
(if (/= "INSERT" (cdr (assoc 0 (entget ent))))
(princ "\nSelected object is not a block.")
)
)
)
)
)
(if (and (= 'ename (type ent)) (setq nbp (getpoint "\nSpecify New Base Point: ")))
(progn
(setq mat (car (revrefgeom ent))
vec (mxv mat (mapcar '- (trans nbp 1 0) (trans (cdr (assoc 10 (entget ent))) ent 0)))
bln (LM:blockname (vlax-ename->vla-object ent))
)
(LM:startundo (LM:acdoc))
(vlax-for lay (vla-get-layers (LM:acdoc))
(if (= :vlax-true (vla-get-lock lay))
(progn
(vla-put-lock lay :vlax-false)
(setq lck (cons lay lck))
)
)
)
(vlax-for obj (vla-item (vla-get-blocks (LM:acdoc)) bln)
(vlax-invoke obj 'move vec '(0.0 0.0 0.0))
)
(if flg
(vlax-for blk (vla-get-blocks (LM:acdoc))
(if (= :vlax-false (vla-get-isxref blk))
(vlax-for obj blk
(if
(and
(= "AcDbBlockReference" (vla-get-objectname obj))
(= bln (LM:blockname obj))
(vlax-write-enabled-p obj)
)
(vlax-invoke obj 'move '(0.0 0.0 0.0) (mxv (car (refgeom (vlax-vla-object->ename obj))) vec))
)
)
)
)
)
(if (= 1 (cdr (assoc 66 (entget ent))))
(progn
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(vl-cmdf "_.attsync" "_N" bln)
(setvar 'cmdecho cmd)
)
)
(foreach lay lck (vla-put-lock lay :vlax-true))
(vla-regen (LM:acdoc) acallviewports)
(LM:endundo (LM:acdoc))
)
)
(princ)
)

;; RefGeom (gile)
;; Returns a list whose first item is a 3x3 transformation matrix and
;; second item the object insertion point in its parent (xref, block or space)

(defun refgeom ( ent / ang enx mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(mapcar '(lambda ( v ) (trans v 0 ocs t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
(mxm
(list
(list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(list
(list (cdr (assoc 41 enx)) 0.0 0.0)
(list 0.0 (cdr (assoc 42 enx)) 0.0)
(list 0.0 0.0 (cdr (assoc 43 enx)))
)
)
)
)
(mapcar '- (trans (cdr (assoc 10 enx)) ocs 0)
(mxv mat (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx))))))
)
)
)

;; RevRefGeom (gile)
;; The inverse of RefGeom

(defun revrefgeom ( ent / ang enx mat ocs )
(setq enx (entget ent)
ang (cdr (assoc 050 enx))
ocs (cdr (assoc 210 enx))
)
(list
(setq mat
(mxm
(list
(list (/ 1.0 (cdr (assoc 41 enx))) 0.0 0.0)
(list 0.0 (/ 1.0 (cdr (assoc 42 enx))) 0.0)
(list 0.0 0.0 (/ 1.0 (cdr (assoc 43 enx))))
)
(mxm
(list
(list (cos ang) (sin ang) 0.0)
(list (- (sin ang)) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(mapcar '(lambda ( v ) (trans v ocs 0 t))
'(
(1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
)
)
)
(mapcar '- (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
(mxv mat (trans (cdr (assoc 10 enx)) ocs 0))
)
)
)

;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n

(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)

;; Matrix x Matrix - Vladimir Nesterovsky
;; Args: m,n - nxn matrices

(defun mxm ( m n )
((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
)

;; Matrix Transpose - Doug Wilson
;; Args: m - nxn matrix

(defun trp ( m )
(apply 'mapcar (cons 'list m))
)

;; 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
; (strcat
; "\n:: ChangeBlockBasePoint.lsp | Version 1.5 | \\U+00A9 Lee Mac "
; (menucmd "m=$(edtime,0,yyyy)")
; " http://www.lee-mac.com ::"
; ""
; ""
; ""
; )
;)
(princ)

;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;

;;; Copy selected entities and paste it as block in one command
;;; Created by Henrique hmsilva http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/copy-and-paste-as-block/td-p/6022554
;;; Modified by Igal Averbuh 2017 (entlast modification of Lee Mak routine)
(defun c:cpb (/ ss)
(command "ucs" "w")
(setvar "cmdecho" 0)
(setvar "osmode" 167)
(command "-layer" "u" "*" "")
(princ "\nSelect objects to copy and paste as block:")
(setq ss (ssget))

(command "_.copybase" '(0.0 0.0 0.0) ss "" "_.pasteblock" '(0.0 0.0 0.0))
(command "erase" ss "")

(command "ucs" "previous")
(setvar "ucsicon" 1)
(setvar "cmdecho" 1)
(princ)
(c:CBPR)
)
;(c:cpb)

Rotate selected objects by Example Source Rotation


;;; Rotate selected objects by Example Source Rotation
;;; Based on Kent Cooper approach
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-routine-to-match-the-text-rotation-only/td-p/1254583
;;; Slightly modified by Igal Averbuh 2017

(defun C:RX (/ tsel tdata ss ml rot tobj); = Match Rotation
(vl-load-com)
(if
(and
(setq tsel (entsel "\nSelect Source for Rotation: "))
(wcmatch (cdr (assoc 0 (setq tdata (entget (car tsel))))) "*TEXT,INSERT,MULTILEADER")
(setq ss (ssget '((0 . "*TEXT,INSERT,MULTILEADER"))))
); and
(progn
(setq
ml (member '(0 . "MULTILEADER") tdata)
rot (cdr (assoc (if ml 42 50) tdata))
); setq
(repeat (setq n (sslength ss))
(setq
tobj (vlax-ename->vla-object (ssname ss (setq n (1- n))))
ml (= (vla-get-ObjectName tobj) "AcDbMLeader")
); setq
(vlax-put tobj (if ml 'TextRotation 'Rotation) rot)
); repeat
); progn
); if
(princ)
); defun
(c:rx)