• Add-On’s
  • Download
  • History of AutoLISP
  • Lisp Resources
  • Run an AutoLISP

LispBox

~ This blog was initially created for people, who love autolisp routines, as I love it.

Monthly Archives: August 2017

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

31 Thursday Aug 2017

Posted by danglar71 in draw

≈ Leave a comment


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

31 Thursday Aug 2017

Posted by danglar71 in draw

≈ Leave a comment


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

30 Wednesday Aug 2017

Posted by danglar71 in draw

≈ Leave a comment


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

30 Wednesday Aug 2017

Posted by danglar71 in draw

≈ Leave a comment


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

16 Wednesday Aug 2017

Posted by danglar71 in Blocks

≈ Leave a comment


;;------------=={ 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

14 Monday Aug 2017

Posted by danglar71 in Blocks, Points

≈ Leave a comment


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

14 Monday Aug 2017

Posted by danglar71 in Blocks, Points

≈ Leave a comment


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

09 Wednesday Aug 2017

Posted by danglar71 in Blocks, Utilites

≈ Leave a comment


;;--------------------=={ 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

02 Wednesday Aug 2017

Posted by danglar71 in Utilites

≈ Leave a comment


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

Recent Posts

  • Это наша плата за трусость
  • Set the Default Application to open DWG Files
  • Draw “Heat Grid” (Lee Mac)
  • PROGRAM FOR SPRINKLER DISTRIBUTION
  • How to remove Frames around blocks

Recent Comments

Wilmer Lacayo on Draw Centroid (center of gravi…
Jun on Convert Polylines to Leaders i…
Adel on HVAC Draw Branch Duct
danglar71 on Draw “Heat Grid” (…
IOAN VLAD on Draw “Heat Grid” (…

Archives

  • January 2021
  • March 2020
  • February 2020
  • January 2020
  • October 2019
  • September 2019
  • August 2019
  • July 2019
  • June 2019
  • May 2019
  • April 2019
  • February 2019
  • January 2019
  • December 2018
  • November 2018
  • October 2018
  • September 2018
  • August 2018
  • July 2018
  • June 2018
  • April 2018
  • March 2018
  • February 2018
  • January 2018
  • December 2017
  • November 2017
  • August 2017
  • July 2017
  • June 2017
  • May 2017
  • April 2017
  • March 2017
  • February 2017
  • January 2017
  • December 2016
  • November 2016
  • October 2016
  • September 2016
  • August 2016
  • July 2016
  • June 2016
  • May 2016
  • April 2016
  • March 2016
  • February 2016
  • January 2016
  • December 2015
  • November 2015
  • October 2015
  • September 2015
  • August 2015
  • July 2015
  • June 2015
  • May 2015
  • April 2015
  • March 2015
  • February 2015
  • January 2015
  • December 2014
  • November 2014

Categories

  • 3D
  • Annonymous Blocks
  • Attribute
  • Batch
  • Blocks
  • Books
  • Common
  • Coordinates
  • Counting
  • dimmensions
  • draw
  • Export
  • Fractal
  • Hatch
  • HVAC
  • Images
  • Import
  • Info
  • Isometric
  • Layers
  • Layouts
  • Lisp Collection 2014
  • Mline
  • Pdf
  • Pipes
  • plot
  • Points
  • Protect
  • Text
  • Tips (English)
  • Tips (Russian)
  • ucs
  • Utilites
  • view
  • Vport
  • Xref

Recent Posts

  • Это наша плата за трусость
  • Set the Default Application to open DWG Files
  • Draw “Heat Grid” (Lee Mac)
  • PROGRAM FOR SPRINKLER DISTRIBUTION
  • How to remove Frames around blocks

Recent Comments

Wilmer Lacayo on Draw Centroid (center of gravi…
Jun on Convert Polylines to Leaders i…
Adel on HVAC Draw Branch Duct
danglar71 on Draw “Heat Grid” (…
IOAN VLAD on Draw “Heat Grid” (…

Archives

  • January 2021
  • March 2020
  • February 2020
  • January 2020
  • October 2019
  • September 2019
  • August 2019
  • July 2019
  • June 2019
  • May 2019
  • April 2019
  • February 2019
  • January 2019
  • December 2018
  • November 2018
  • October 2018
  • September 2018
  • August 2018
  • July 2018
  • June 2018
  • April 2018
  • March 2018
  • February 2018
  • January 2018
  • December 2017
  • November 2017
  • August 2017
  • July 2017
  • June 2017
  • May 2017
  • April 2017
  • March 2017
  • February 2017
  • January 2017
  • December 2016
  • November 2016
  • October 2016
  • September 2016
  • August 2016
  • July 2016
  • June 2016
  • May 2016
  • April 2016
  • March 2016
  • February 2016
  • January 2016
  • December 2015
  • November 2015
  • October 2015
  • September 2015
  • August 2015
  • July 2015
  • June 2015
  • May 2015
  • April 2015
  • March 2015
  • February 2015
  • January 2015
  • December 2014
  • November 2014

Categories

  • 3D
  • Annonymous Blocks
  • Attribute
  • Batch
  • Blocks
  • Books
  • Common
  • Coordinates
  • Counting
  • dimmensions
  • draw
  • Export
  • Fractal
  • Hatch
  • HVAC
  • Images
  • Import
  • Info
  • Isometric
  • Layers
  • Layouts
  • Lisp Collection 2014
  • Mline
  • Pdf
  • Pipes
  • plot
  • Points
  • Protect
  • Text
  • Tips (English)
  • Tips (Russian)
  • ucs
  • Utilites
  • view
  • Vport
  • Xref

Blog at WordPress.com.

Privacy & Cookies: This site uses cookies. By continuing to use this website, you agree to their use.
To find out more, including how to control cookies, see here: Cookie Policy