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))

Advertisements

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)

Rotate selected text by example Text Source Rotation


;;; Rotate selected text by example Text Source Rotation
;;; Created by Kent Cooper
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-routine-to-match-the-text-rotation-only/td-p/1254583

(defun C:TR (/ tsel tdata ss ml rot tobj); = Match Text Rotation
(vl-load-com)
(if
(and
(setq tsel (entsel "\nSelect Text Source for Rotation: "))
(wcmatch (cdr (assoc 0 (setq tdata (entget (car tsel))))) "*TEXT,MULTILEADER")
(setq ss (ssget '((0 . "*TEXT,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:tr)

Divide angle defined by 3 points in drawing to number of parts are drawn from the vertex dividing the angle


;; Pick an angle by three points and choose the number of parts you want to divide the
;; angle into.Lines are drawn from the vertex dividing the angle.
;; Created by Lee Mak
;; Saved from: https://www.theswamp.org/index.php?action=post;quote=487487;topic=43500.0

(defun c:ad ( / a d n p q s v x )
(if (and
(setq v (getpoint "\nPick Angle Vertex: "))
(setq p (getpoint v "\nPick 1st Endpoint: "))
(setq q (getpoint v "\nPick 2nd Endpoint: "))
)
(progn
(initget 6)
(if (null (setq n (getint "\nSpecify Number of Divisions : ")))
(setq n 2)
)
(if (not (LM:Clockwise-p p v q))
(setq x p p q q x)
)
(setq a (/ (LM:GetInsideAngle p v q) n)
s (+ a (angle v p))
d (max (distance v p) (distance v q))
)
(repeat (1- n)
(entmake (list '(0 . "LINE") (cons 10 (trans v 1 0)) (cons 11 (trans (polar v s d) 1 0))))
(setq s (+ s a))
)
)
)
(princ)
)

;; Get Inside Angle - Lee Mac
;; Returns the smaller angle subtended by three points with vertex at p2

(defun LM:GetInsideAngle ( p1 p2 p3 )
( (lambda ( a ) (min a (- (+ pi pi) a)))
(rem (+ pi pi (- (angle p2 p1) (angle p2 p3))) (+ pi pi))
)
)

;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented

(defun LM:Clockwise-p ( p1 p2 p3 )
(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
)

(c:ad)

Block Offset with user specified offset distance, distance between blocks and Rotate Blocks Around it Base Point


;;; Block Offset with user specified offset distance, distance between blocks and nd Rotate Blocks Around it Base Point
;;; Created by Igal Averbuh 2017
;;; Inspired by some subroutines of different authors

(defun C:BOR ( / pl1 pl2 bname pt1 odist)

(vl-load-com)
(cond
((and
(setq ent (car (entsel "\nSelect Block Entity: ")))
(setq bname (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 bname (getstring "\nType Block name: "))
(setq pl1 (car (entsel "\nSelect polyline: ")))
(setq pt1 (getpoint "\nPick side to offset to: "))
(setq odist (getdist pt1 "\nDistance to offset Polyline:"))
(setq odist1 (getdist pt1 "\nDistance between Blocks:"))
(command "_offset" odist pl1 pt1 "")
(setq pl2 (entlast))
(command "_measure" pl2 "_b" bname "_y" odist1)

(setq ss (ssget "P"))
(if (not ss) (setq ss (ssx)))
(setq num (sslength ss))
(setq x 0)
(if ss
(if (setq ang (getreal "Enter Rotation Angle: "))
(repeat num
(setq ename (ssname ss x))
(setq elist (entget ename))
(setq pnt (cdr(assoc 10 elist)))
(command "Rotate" ename "" pnt ang)
(setq x (1+ x))
)
)
)
)

(c:bor)

Measure by selected Block with user specified distance between blocks and Rotate Blocks Around it Base Point


;;; Measure by selected Block with user specified distance between blocks and Rotate Blocks Around it Base Point
;;; Created by Igal Averbuh 2017
;;; Inspired by some subroutines of different authors

(defun C:MBL ( / pl1 pl2 bname pt1 odist)

(vl-load-com)
(cond
((and
(setq ent (car (entsel "\nSelect Block Entity: ")))
(setq bname (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 pl1 (car (entsel "\nSelect polyline: ")))

(setq odist1 (getdist "\nDistance between Blocks:"))

(command "_measure" pl1 "_b" bname "_y" odist1)

(setq ss (ssget "P"))
(if (not ss) (setq ss (ssx)))
(setq num (sslength ss))
(setq x 0)
(if ss
(if (setq ang (getreal "Enter Rotation Angle: "))
(repeat num
(setq ename (ssname ss x))
(setq elist (entget ename))
(setq pnt (cdr(assoc 10 elist)))
(command "Rotate" ename "" pnt ang)
(setq x (1+ x))
)
)
)
)

(c:mbl)

Measure by selected Block with user specified distance between blocks


;;; Measure by selected Block with user specified distance between blocks
;;; Created by Igal Averbuh 2017
;;; Inspired by some subroutines of different authors

(defun C:MBL ( / pl1 pl2 bname pt1 odist)

(vl-load-com)
(cond
((and
(setq ent (car (entsel "\nSelect Block Entity: ")))
(setq bname (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 pl1 (car (entsel "\nSelect polyline: ")))

(setq odist1 (getdist "\nDistance between Blocks:"))

(command "_measure" pl1 "_b" bname "_y" odist1)
)
(c:mbl)

System variable that controls Shortcut Menus in the drawing area

This Is SHORTCUTMENU

Controls whether Default, Edit, and Command mode shortcut menus are available in the drawing area. The setting is stored as a bitcode using the sum of the following values:

0
Disables all Default, Edit, and Command mode shortcut menus, restoring AutoCAD Release 14 behavior.

1
Enables Default mode shortcut menus.

2
Enables Edit mode shortcut menus.

4
Enables Command mode shortcut menus whenever a command is active.

8
Enables Command mode shortcut menus only when command options are currently available from the command line.

16
Enables display of a shortcut menu when the right button on the pointing device is held down longer

My Lisp’s to toggle “shortcut menus in drawing area” on and off


(defun c:s0()
(command "SHORTCUTMENU""0")
(princ)
)

(defun c:s1()
(command "SHORTCUTMENU""1")
(princ)
)