• 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.

Category Archives: Blocks

Lisps for Block modify

Block Preview – Lee Mac

29 Wednesday Jan 2020

Posted by danglar71 in Blocks

≈ Leave a comment


;; Block Preview Example Program - Lee Mac
;; Short program to demonstrate DCL Block Preview function

(defun c:bpreview ( / *error* _blockpreview dcl def des lst tmp )

(defun *error* ( msg )
(if (< 0 dcl)
(unload_dialog dcl)
)
(if (= 'file (type des))
(close des)
)
(if (and tmp (findfile tmp))
(vl-file-delete tmp)
)
(if (and msg (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")))
(princ (strcat "\nError: " msg))
)
(princ)
)

(defun _blockpreview ( blk )
(start_image "img")
(fill_image 0 0 (dimx_tile "img") (dimy_tile "img") 0)
(LM:BlockPreview "img" blk 5)
(end_image)
)

(while (setq def (tblnext "BLOCK" (null def)))
(if
(and
(= 0 (logand 125 (cdr (assoc 70 def))))
(not (wcmatch (cdr (assoc 2 def)) "`_*,`**,*|*"))
)
(setq lst (cons (cdr (assoc 2 def)) lst))
)
)

(cond
( (null (setq lst (vl-sort lst '<)))
(princ "\nNo blocks found in drawing.")
)
( (null
(and
(setq tmp (vl-filename-mktemp nil nil ".dcl"))
(setq des (open tmp "w"))
(foreach line
'(
"blockpreview : dialog"
"{"
" label = \"Block Preview\";"
" spacer;"
" : row"
" {"
" : list_box { key = \"lst\"; width = 30.0; fixed_width = true; }"
" spacer;"
" : image"
" {"
" key = \"img\";"
" width = 33.5;"
" aspect_ratio = 1.0;"
" fixed_width = true;"
" fixed_height = true;"
" }"
" }"
" spacer;"
" ok_only;"
"}"
)
(write-line line des)
)
(not (setq des (close des)))
(PointList en))
(if (or (= "POINT" (cdr (assoc 0 el))) (vlax-curve-isclosed en))
(setq pl (cons (last pl) pl))
)
(setq ec (_getcolour el))
(setq vl
(append vl
(mapcar
(function
(lambda ( a b )
(list (car a) (cadr a) (car b) (cadr b) ec)
)
)
pl (cdr pl)
)
)
)
)
)
)
)
vl
)

(defun _unique ( l / a r )
(while (setq a (car l))
(setq r (cons a r)
l (vl-remove-if (function (lambda ( b ) (equal a b))) (cdr l))
)
)
(reverse r)
)

(cond
( (or (< margin 0)
(<= (setq xt (dimx_tile key)) (* 2 margin))
(<= (setq yt (dimy_tile key)) (* 2 margin))
)
nil
)
( (setq vl (assoc (strcase block) cache))
(foreach x (cdr vl) (apply 'vector_image x))
t
)
( (setq vl (_getvectors block))
(setq mi (apply 'mapcar (cons 'min vl))
mx (apply 'mapcar (cons 'max vl))
mi (list (min (car mi) (caddr mi)) (min (cadr mi) (cadddr mi)))
mx (list (max (car mx) (caddr mx)) (max (cadr mx) (cadddr mx)))
r1 (/ (- (car mx) (car mi)) (- xt (* 2 margin)))
r2 (/ (- (cadr mx) (cadr mi)) (- yt (* 2 margin)))
)
(cond
( (and (equal r1 r2 1e-8) (equal r1 0.0 1e-8))
(setq sc 1.0
vc (mapcar '- mi (list (/ xt 2.0) (/ yt 2.0)))
)
)
( (equal r1 r2 1e-8)
(setq sc r1
vc (mapcar '(lambda ( x ) (- x (* sc margin))) mi)
)
)
( (PointList ( ent / der di1 di2 di3 elst fun inc lst par rad )
(setq elst (entget ent))
(cond
( (eq "POINT" (cdr (assoc 0 elst)))
(list (cdr (assoc 10 elst)))
)
( (eq "LINE" (cdr (assoc 0 elst)))
(list (cdr (assoc 10 elst)) (cdr (assoc 11 elst)))
)
( (member (cdr (assoc 0 elst)) '("CIRCLE" "ARC"))
(setq di1 0.0
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
inc (/ di2 (1+ (fix (* 35.0 (/ di2 (cdr (assoc 40 elst)) (+ pi pi))))))
fun (if (vlax-curve-isclosed ent) < <=)
)
(while (fun di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
di1 (+ di1 inc)
)
)
lst
)
( (or (eq (cdr (assoc 0 elst)) "LWPOLYLINE")
(and (eq (cdr (assoc 0 elst)) "POLYLINE") (zerop (logand (cdr (assoc 70 elst)) 80)))
)
(setq par 0)
(repeat (fix (1+ (vlax-curve-getendparam ent)))
(if (setq der (vlax-curve-getsecondderiv ent par))
(if (equal der '(0.0 0.0 0.0) 1e-8)
(setq lst (cons (vlax-curve-getpointatparam ent par) lst))
(if (setq rad (distance '(0.0 0.0) (vlax-curve-getfirstderiv ent par))
di1 (vlax-curve-getdistatparam ent par)
di2 (vlax-curve-getdistatparam ent (1+ par))
)
(progn
(setq inc (/ (- di2 di1) (1+ (fix (* 35.0 (/ (- di2 di1) rad (+ pi pi)))))))
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
di1 (+ di1 inc)
)
)
)
)
)
)
(setq par (1+ par))
)
(if (or (vlax-curve-isclosed ent) (equal '(0.0 0.0 0.0) der 1e-8))
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
( (eq (cdr (assoc 0 elst)) "ELLIPSE")
(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
di3 (* di2 (/ (+ pi pi) (abs (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)))))
)
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
der (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1)))
di1 (+ di1 (/ di3 (1+ (fix (/ 35.0 (/ di3 der (+ pi pi)))))))
)
)
(if (vlax-curve-isclosed ent)
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
( (eq (cdr (assoc 0 elst)) "SPLINE")
(setq di1 (vlax-curve-getdistatparam ent (vlax-curve-getstartparam ent))
di2 (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent))
inc (/ di2 25.0)
)
(while (< di1 di2)
(setq lst (cons (vlax-curve-getpointatdist ent di1) lst)
;der (/ (distance '(0.0 0.0) (vlax-curve-getsecondderiv ent (vlax-curve-getparamatdist ent di1))) inc)
di1 (+ di1 inc) ;(+ di1 (if (equal 0.0 der 1e-10) inc (min inc (/ 1.0 der (* 10. inc)))))
)
)
(if (vlax-curve-isclosed ent)
lst
(cons (vlax-curve-getendpoint ent) lst)
)
)
)
)

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

(defun trp ( m )
(apply 'mapcar (cons 'list 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 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)
)

(vl-load-com)
(princ)

Change Height of All Attributes in All Blocks in “one shot”

28 Tuesday May 2019

Posted by danglar71 in Attribute, Blocks

≈ Leave a comment


;;;Argument: hgt= height of attribute
;;;Example: ;;;Argument: hgt= height of attribute
;;;Example: (AttHgt 2.5)
;;;Ken Alexander 8/30/02.
(defun AttHgt (hgt / doc selset att catt)
(vl-load-com)
(setq doc (vla-get-activedocument (vla-get-application (vlax-get-acad-object))))
(vla-startundomark doc)
(if (ssget "x" (list (cons 0 "INSERT")))
(setq selset (vla-get-ActiveSelectionSet doc))
)
(if selset
(progn
(vlax-for item selset
(cond
((= (vl-catch-all-apply 'vla-get-HasAttributes (list item))
:vlax-true
)
(setq att (vlax-variant-value (vla-getattributes item))
catt (vlax-variant-value (vla-getconstantattributes item))
)
(if (safearray-value att)
(mapcar '(lambda (x)
(vla-put-height x hgt))
(vlax-safearray->list att)
)
)
(if (safearray-value catt)
(mapcar '(lambda (x) (vla-put-height x hgt))
(vlax-safearray->list catt)
)
)
(vla-update item)
)
)
)
)
)
(vla-endundomark doc)
(princ)
)
;;;Ken Alexander 8/30/02.
(defun AttHgt (hgt / doc selset att catt)
(vl-load-com)
(setq doc (vla-get-activedocument (vla-get-application (vlax-get-acad-object))))
(vla-startundomark doc)
(if (ssget "x" (list (cons 0 "INSERT")))
(setq selset (vla-get-ActiveSelectionSet doc))
)
(if selset
(progn
(vlax-for item selset
(cond
((= (vl-catch-all-apply 'vla-get-HasAttributes (list item))
:vlax-true
)
(setq att (vlax-variant-value (vla-getattributes item))
catt (vlax-variant-value (vla-getconstantattributes item))
)
(if (safearray-value att)
(mapcar '(lambda (x)
(vla-put-height x hgt))
(vlax-safearray->list att)
)
)
(if (safearray-value catt)
(mapcar '(lambda (x) (vla-put-height x hgt))
(vlax-safearray->list catt)
)
)
(vla-update item)
)
)
)
)
)
(vla-endundomark doc)
(princ)
)

Count blocks within viewport selected by user with table output

19 Tuesday Feb 2019

Posted by danglar71 in Blocks, Counting

≈ Leave a comment


;;; Count blocks within viewport selected by user with table output
;;; Based on Jimmy Bergmark, Lee Mac, Kent Cooper, DannyNL and Marco Antonio Jacinto Perez and BeekeeCZ subroutines
;;; Solution for blocks counting inside closed polyline saved from:
;;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-request-block-count-inside-a-closed-polyline/td-p/7665364
;;; Final routine created by Igal Averbuh 2019 (combined from existing routines with some modifications)

;;; Rotates tables around their insertion points
;;; Created by BeekeeCZ
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-rotate-acad-table/td-p/8771700

(defun c:ROT ( / ss i ent dir pnt eng ucs)

(if (setq ss (ssget "L" '((0 . "ACAD_TABLE"))))
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq dir (getpropertyvalue ent "Direction"))
(setq pnt (cdr (assoc 10 (entget ent))))
(setq ang (angle '(0 0 0) dir))
(setq ucs (angle '(0 0 0) (getvar 'UCSXDIR)))
(command "_.rotate" ent "" "_non" (trans pnt 0 1) "_R" (angtos ang (getvar 'AUNITS) 8) (angtos ucs (getvar 'AUNITS) 8))))
(princ)
)

;; ScaleAboutCenters.lsp [command name: SAC]
;; To Scale multiple objects, each About its own Center, by the same User-specified
;; scale factor.
;; Uses the middle of each object's bounding box as the base point for scaling, to
;; keep objects centered at approximately the same position in the drawing.
;; [For Mtext, that will be based on the defined Mtext box width, not the extents
;; of the content; for a Block or Text, the center of its extents in the drawing, not
;; its insertion point; for an Arc, the center of its extents, not its geometric center;
;; some entity types' (e.g. Spline's) bounding box can sometimes reach beyond
;; its extents and affect results slightly.]
;; Rejects selection of objects on locked Layers, or without a "center" [Rays, Xlines].
;; Stores scale factor; offers as default on subsequent use in same editing session.
;; Kent Cooper, 6 May 2014

(defun C:SAC (/ *error* cmde ss inc ent)
(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); end if
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); end defun - *error*
(setq cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(command "_.undo" "_begin")
(setq *SACscl
(cond
( (getreal
(strcat
"\nEnter Scale Factor for blocks couning table : "
); strcat
); getreal
); User-input condition
(*SACscl); Enter on subsequent use [prior value]
(1); Enter on first use
); cond & *SACscl
ss (ssget "L" '((-4 . "")))
;; not objects on Locked Layers or without finite extents
); setq
(repeat (setq inc (sslength ss))
(setq ent (ssname ss (setq inc (1- inc))))
(vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
(command
".scale" ent "" "_none"
(mapcar '/ ; midpoint of bounding box
(mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt))
'(2 2 2)
); mapcar
*SACscl
); command
); repeat
(command "_.undo" "_end")
(setvar 'cmdecho cmde)
(princ)
); defun
(vl-load-com)

;;; vp-outline.lsp
;;;
;;; Creates a polyline in modelspace that
;;; has the outline of the selected viewport.
;;; Supports clipped viewports. polyline is supported
;;; ellipse, spline, region and circle not supported at this point
;;; If vp-outline is called when in mspace it detects
;;; the active viewport.
;;;
;;; c:vp-outline
;;;
;;; By Jimmy Bergmark
;;; Copyright (C) 1997-2013 JTB World, All Rights Reserved
;;; Website: http://www.jtbworld.com
;;; E-mail: info@jtbworld.com
;;;
;;; 2000-04-10
;;; 2003-11-19 Added support for drawing the outline in other ucs/view than world/current
;;;
;;; 2006-04-06 Added support for twisted views Tom Beauford
;;; 2013-06-08 Added support for circular viewports
;;;
;;; Should work on AutoCAD 2000 and newer
(vl-load-com)

(defun dxf (n ed) (cdr (assoc n ed)))

(defun ax:List->VariantArray (lst)
(vlax-Make-Variant
(vlax-SafeArray-Fill
(vlax-Make-SafeArray
vlax-vbDouble
(cons 0 (- (length lst) 1))
)
lst
)
)
)

(defun c:vp-outline (/ ad ss ent pl plist xy n vpbl vpur msbl msur ven vpno ok
circ)
(setq ad (vla-get-activedocument (vlax-get-acad-object)))
(if (= (getvar "tilemode") 0)
(progn
(if (= (getvar "cvport") 1)
(progn
(if (setq ss (ssget ":E:S" '((0 . "VIEWPORT"))))
(progn (setq ent (ssname ss 0))
(setq vpno (dxf 69 (entget ent)))
(vla-Display (vlax-ename->vla-object ent) :vlax-true)
(vla-put-mspace ad :vlax-true) ; equal (command "._mspace")
; this to ensure trans later is working on correct viewport
(setvar "cvport" vpno)
; (vla-put-mspace ad :vlax-false) ; equal (command "._pspace")
(setq ok T)
(setq ss nil)
)
)
)
(setq ent (vlax-vla-object->ename (vla-get-activepviewport ad))
ok T
)
)
(if ok
(progn (setq circle nil)
(setq ven (vlax-ename->vla-object ent))
(if (/= 1 (logand 1 (dxf 90 (entget ent)))) ; detect perspective
(progn (if (= (vla-get-clipped ven) :vlax-false)
(progn ; not clipped
(vla-getboundingbox ven 'vpbl 'vpur)
(setq vpbl (trans (vlax-safearray->list vpbl) 3 2)
msbl (trans vpbl 2 1)
msbl (trans msbl 1 0)
vpur (trans (vlax-safearray->list vpur) 3 2)
msur (trans vpur 2 1)
msur (trans msur 1 0)
vpbr (list (car vpur) (cadr vpbl) 0)
msbr (trans vpbr 2 1)
msbr (trans msbr 1 0)
vpul (list (car vpbl) (cadr vpur) 0)
msul (trans vpul 2 1)
msul (trans msul 1 0)
plist (list (car msbl)
(cadr msbl)
(car msbr)
(cadr msbr)
(car msur)
(cadr msur)
(car msul)
(cadr msul)
)
)
)
(progn ; clipped
(setq pl (entget (dxf 340 (entget ent))))
(if (= (dxf 0 pl) "CIRCLE")
(setq circle T)
(progn (setq plist (vla-get-coordinates
(vlax-ename->vla-object (dxf -1 pl))
)
plist (vlax-safearray->list (vlax-variant-value plist))
n 0
pl nil
)
(repeat (/ (length plist) 2)
(setq xy (trans (list (nth n plist) (nth (1+ n) plist)) 3 2)
xy (trans xy 2 1)
xy (trans xy 1 0)
pl (cons (car xy) pl)
pl (cons (cadr xy) pl)
n (+ n 2)
)
)
(setq plist (reverse pl))
)
)
)
)
(if circle
(vla-AddCircle
(vla-get-ModelSpace ad)
(ax:List->VariantArray
(trans (trans (trans (dxf 10 pl) 1 0) 2 1) 3 2)
)
(/ (dxf 40 pl) (caddr (trans '(0 0 1) 2 3)))
)
(vla-Put-Closed
(vla-AddLightWeightPolyline
(vla-get-ModelSpace ad)
(ax:List->VariantArray plist)
)
:vlax-True
)
)
)
)
)
)
)
)
(if ss
(vla-put-mspace ad :vlax-false)
) ; equal (command "._pspace"))
(princ)
)

(defun c:bc (/ T_OldPdmode T_Selection T_Entity T_LowerLeft T_UpperRight T_Precision T_Position T_PointList T_Count T_EntityList T_CheckLine T_IntersectPoints T_BoundaryCheck T_BlockName T_BlockList)
(if
(and
(princ "\nSelect polyline: ")
(setq T_Selection (ssget "L" '((0 . "*POLYLINE"))))
(setq T_Object (vlax-ename->vla-object (ssname T_Selection 0)))
(vlax-Curve-isClosed T_Object)
(vlax-Curve-isPlanar T_Object)
)
(progn
(setq T_Precision 0.1)
(setq T_Position 0.0)
(while
(list (list (vlax-variant-value (vla-IntersectWith (vlax-ename->vla-object T_CheckLine) T_Object acExtendNone)))))))
(= (rem (length (_GroupByNum T_IntersectPoints 3)) 2) 1)
)
(progn
(if
(not (assoc (setq T_BlockName (cdr (assoc 2 T_EntityList))) T_BlockList))
(setq T_BlockList (cons (list T_BlockName 1) T_BlockList))
(setq T_BlockList (subst (list T_BlockName (1+ (cadr (assoc T_BlockName T_BlockList)))) (assoc T_BlockName T_BlockList) T_BlockList))
)
)
(ssdel T_Entity T_Selection)
)
(if T_CheckLine (entdel T_CheckLine))
)
;(sssetfirst nil T_Selection)
(acet-ui-progress)
(princ (strcat "\n ** Total number of blocks found: " (itoa (sslength T_Selection)) "\n"))
(foreach T_Item (vl-sort T_BlockList '(lambda (T_Block1 T_Block2) (variantArray
(ptsList / arraySpace sArray)
(setq
arraySpace(vlax-make-safearray
vlax-vbdouble;elemento tipo
(cons 0(-(length ptsList)1));_ array dimension
)
)
(setq sArray(vlax-safearray-fill arraySpace ptsList))
(vlax-make-variant sArray)
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun NameUnnamedUcs
(*adoc* UcsName / *UCS* Origin XAxisPoint YAxisPoint)
(if(=(getvar"WORLDUCS")0);If UCS Difers from world then
(progn
(Setq *UCS*(vla-get-UserCoordinateSystems *adoc*)
Origin(getvar "UCSORG")
XAxisPoint(mapcar
'(lambda(pt1 pt2)(+ pt1 pt2))
Origin
(getvar "UCSXDIR")
)
YAxisPoint(mapcar
'(lambda(pt1 pt2)(+ pt1 pt2))
Origin
(getvar"UCSyDIR")
)
)
(vla-add
*Ucs*(list->variantArray Origin)
(list->variantArray XAxisPoint)
(list->variantArray YAxisPoint)
UcsName
)
)
)
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun GetBlocks (space /)
(cond
((=(Type Space)'STR)(vlax-for obj(vla-get-block(vla-item *layouts* space))(bkobj obj)))
((=(Type Space)'PICKSET)
(for-sset Space
(lambda(ename / obj)
(setq obj (vlax-ename->vla-object ename))
(bkobj obj)
)
)
)
)
BkCountLst
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun bkObj (obj / BkName)
(cond ((/= (vla-get-ObjectName obj) "AcDbBlockReference"))
((and
(setq BkName (vla-get-Name obj))
(assoc BkName BkCountLst)
)
(setq BkCountLst
(subst (cons BkName (1+ (cdr (assoc BkName BkCountLst))))
(assoc BkName BkCountLst)
BkCountLst
)
)
)
(T
(setq BkCountLst
(cons (cons BkName 1) BkCountLst)
)
)
)
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

(Defun c:BTL (/ *acad* *adoc* *Layouts* BkCountLst SpaceBkCt ptt *tabla* Table1 *BLOCKS* CTROW ROW
*TABLESTYLE* CTC COL_CT LayName NwUcs ss)
(setq *acad* (vlax-get-acad-object)
*adoc* (vla-get-activedocument *acad*)
*Layouts* (vla-get-Layouts *adoc*)
*blocks* (vla-get-Blocks *adoc*)
)
(vla-startundomark *adoc*)
(or (setq NwUcs (collection-item-p (vla-get-UserCoordinateSystems *adoc*) "BTUcs")))

(initget "Selection ModelSpace PaperSpace Total")
(setq SpaceBkCt (GetKword
"\n Press Enter to Count Blocks in this ViewPort.."
)
)
(cond ((or (= SpaceBkCt "ViewPort") (= SpaceBkCt nil))
(setq SpaceBkCt "ViewPort")
(while (null ss)
(setq ss (ssget "P" '((0 . "INSERT"))))
)
(princ "\n Getting Blocks in ViewPort...")
(GetBlocks ss)
)

((= SpaceBkCt "ModelSpace")
(setq SpaceBkCt "Model Space")
(princ "\n Getting Blocks in ModelSpace...")
(GetBlocks "Model")
)

((= SpaceBkCt "PaperSpace")
(initget "All Type Current")
(setq GetPs (GetKword
"\n Count Blocks in [/Type Name/All] layouts: "
)
)
;;; ----------
(cond ((or (= GetPs nil) (= GetPs "Current"))
(princ "\n Getting Blocks in Current Layout...")
(GetBlocks (getvar "ctab"))
(setq SpaceBkCt "Paper Space")
)
((= GetPs "All")
(princ "\n Getting Blocks in all Layouts...")
(setq Layouts (layoutlist))
(foreach lay layouts
(GetBlocks lay)
)
(setq SpaceBkCt "all Layouts")
)
(t
(while (not (member LayName (mapcar 'strcase (layoutlist))))
(setq LayName (strcase (getString "\n Type layout name: " T)))
)
(mapcar 'princ
(list "\n Getting Blocks in Layout " LayName "...")
)
(GetBlocks LayName)
(setq SpaceBkCt (strcat "Layout " LayName))
)
)
;;; ------------
)
(t
(princ "\n Getting Blocks in Paper and Model Space...")
(setq Layouts (cons "Model" (layoutlist)))
(foreach lay layouts
(GetBlocks lay)
)
)
)
(if BkCountLst
(progn
(setq BkCountLst
(vl-sort BkCountLst
(function (lambda (e1 e2)
(< (car e1) (car e2))
)
)
)
)
(princ "Done")
(cond ((collection-item-p
(vla-get-dictionaries *adoc*)
"TablaBlocks"
)
)
(T
(AddTextStyle "Anot_Arial" "ARIAL" *adoc*)
(setq *tableStyle* (vla-item (vla-get-dictionaries *adoc*)
"acad_tablestyle"
)
*tabla* (vla-addObject
*tableStyle*
"TablaBlocks"
"AcDbTableStyle"
)
)
(vla-SetTextHeight *tabla* acTitleRow 5.0);altura texto rotulo principal
(vla-SetTextHeight *tabla* acHeaderRow 3.5);altura texto rotulo bloques
(vla-SetTextHeight *tabla* acDataRow 3.5);altura texto bloques
(vla-SetTextStyle *tabla* acHeaderRow "Anot_Arial")
(vla-SetTextStyle *tabla* acTitleRow "Anot_Arial")
(vla-SetTextStyle *tabla* acDataRow "Anot_Arial")
(vla-put-Vertcellmargin *tabla* 3.5)
(vla-put-Horzcellmargin *tabla* 10.0)
)
)
(or ptt
(setq
ptt
;(trans
(getPoint
"\nSelect insertion point of Tasble: "
)
;;; 1
;;; 0
;;; )
)
)
(progn
(princ "\n Creating Table, please wait... ")
(setq Ptt (vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
'(0 . 2)
)
ptt
)
)
Table1 (vla-addTable
(vla-get-ModelSpace
*adoc*
)
ptt
2
3
0.2
2.0
)
ctc 0
)
(vla-put-StyleName Table1 "TablaBlocks")
(vla-setText
Table1
0
0
(strcase (strcat "Blocks in "
(if (= SpaceBkCt "Total")
"Drawing"
SpaceBkCt
)
)
)
)
(vla-setText Table1 1 0 "Picture")
(vla-setText Table1 1 1 "Block Name")
(vla-setText Table1 1 2 "Count")
(vla-setcolumnwidth Table1 0 40.0);anchura columna bloque
(vla-setcolumnwidth Table1 1 100.0);anchura columna nombre
(vla-setcolumnwidth Table1 2 33.0);anchura columna cantidad
(vla-setRowHeight Table1 0 5)
(vla-setrowHeight Table1 1 3.5)
(if (setq NwUcs (NameUnnamedUcs *adoc* "BTUcs"))
(progn
(setq TransMatrix (vla-getUcsMatrix NwUcs))
(vla-TransformBy Table1 TransMatrix)
)
)
)

(setq row 2)
(foreach BksLst BkCountLst
(vla-insertrows Table1 row 0.35 1)
(setq Col_ct 0)
(vla-SetCellType Table1 row Col_ct acBlockCell)
(vla-SetBlockTableRecordId
Table1
row
Col_ct
(vla-get-ObjectID (vla-item *blocks* (car BksLst)))
:vlax-true
)
(setq col_ct (1+ Col_Ct)
)
(vla-SetText
Table1
(vlax-make-Variant row vlax-vbLong)
Col_ct
(vlax-Make-Variant (strcase (car BksLst)) Vlax-VbString)
)
(setq col_ct (1+ Col_Ct)
)
(vla-SetText
Table1
(vlax-make-Variant row vlax-vbLong)
Col_ct
(vlax-Make-Variant (cdr BksLst) Vlax-VbString)
)
(setq row (1+ row)
)
)
(setq ctrow 2)
(repeat (- (vla-get-rows table1) 2)
(vla-setcellalignment Table1 ctrow 1 acmiddleleft)
(setq ctrow (1+ ctrow))
)
(princ "Done")
)
(mapcar 'princ
(list "\n There are not blocks references in "
SpaceBkCt
"."
)
)
)
(vla-endundomark *adoc*)
(prin1)
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

(defun c:vbc()
(command "_.-LAYER" "_T" "0-BLOCKS-COUNTING" "_U" "0-BLOCKS-COUNTING" "_M" "0-BLOCKS-COUNTING" "_C" 1 "0-BLOCKS-COUNTING" "")
(princ "\n Select ViewPort for Blocks Counting...")
(c:vp-outline)
(c:bc)
(setvar "osmode" 0)
(c:btl)
(command "._chspace" "L" "" "")
(c:rot)
(c:sac)
(setvar "osmode" 167)
)
;(c:vbc)

Draw background wide polyline under block external contour (Block Mask)

03 Thursday Jan 2019

Posted by danglar71 in Blocks, draw

≈ 2 Comments


;;; Draw background wide polyline under block external contour (Block Mask)
;;; Created (combined from existing routines) by Igal Averbuh 2019
;;; Based on Polyline Width Lee Mac routine and routine saved from: http://www.autocad.ru/cgi-bin/f1/board.cgi?t=30724Ed

;; Polyline Width - Lee Mac
;; Applies a given constant width to all segments in a selection of polylines.

(defun c:pw ( / *error* idx sel wid )

(defun *error* ( msg )
(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 "\nSelect polylines: " '("_:L" ((0 . "LWPOLYLINE,POLYLINE")))))

(setq sel (ssget "L"))

(progn
(initget 4)
(setq wid 1.0) ;here to set wigth op backgroung polyline
;(setq wid (getdist "\nEnter New Width: "))
(repeat (setq idx (sslength sel))
(vla-put-constantwidth (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) wid)
)
)
)
(*error* nil)
(princ)
)

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

;;; ! *********************************************************
;;; ! lib:IsPtInView *
;;; ! *********************************************************
;;; ! ????????? ????????? ?? ????? ? ??????? ?????? *
;;; ! Auguments: 'pt' — ????? ??? ??????? ? ???!!! *
;;; ! Return : T ??? nil ???? 'pt' ? ??????? ?????? ??? ??? *
;;; ! *********************************************************
(defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc)
(setq pt (trans pt 0 1))
(setq VCTR (getvar "VIEWCTR")
Y_Len (getvar "VIEWSIZE")
SSZ (getvar "SCREENSIZE")
X_Pix (car SSZ)
Y_Pix (cadr SSZ)
X_Len (* (/ X_Pix Y_Pix) Y_Len)
Lc (polar VCTR (dtr 180.0) (* 0.5 X_Len))
Uc (polar Lc 0.0 X_Len)
Lc (polar Lc (dtr 270.0) (* 0.5 Y_Len))
Uc (polar Uc (dtr 90.0) (* 0.5 Y_Len))
)
(if (and (> (car pt) (car Lc))
( (cadr pt) (cadr Lc))
(vla-object
(vl-remove-if
'listp
(mapcar 'cadr (ssnamex sel))
)
)
)
(setq csp
(vla-objectidtoobject
adoc
(vla-get-ownerid (car sel))
)
)
(setq unnamed_block
(vla-add (vla-get-blocks adoc)
(vlax-3d-point '(0. 0. 0.))
"*U"
)
)
(foreach x sel
(setq oname
(strcase (vla-get-objectname x))
lay
(vla-item lays (vla-get-layer x))
)
(if (= (vla-get-lock lay) :vlax-true)
(progn
(vla-put-lock lay :vlax-false)
(setq loc (cons lay loc))
)
)
(cond
((member oname '("ACDBVIEWPORT" "ACDBATTRIBUTEDEFINITION"))
nil
)
((= oname "ACDBBLOCKREFERENCE")
(vla-InsertBlock
unnamed_block
(vla-get-insertionpoint x)
(vla-get-name x)
(vla-get-xscalefactor x)
(vla-get-yscalefactor x)
(vla-get-zscalefactor x)
(vla-get-rotation x)
)
(setq blk (cons x blk))
)
(t (setq obj (cons x obj)))
)
) ;_foreach
(setq lay
(vla-item lays (getvar "CLAYER"))
)
(if
(= (vla-get-lock lay) :vlax-true)
(progn (vla-put-lock lay :vlax-false)
(setq loc (cons lay loc))
)
)
(if obj
(progn
(vla-copyobjects
(vla-get-activedocument
(vlax-get-acad-object)
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length obj)))
)
obj
)
)
unnamed_block
)
)
)
(setq obj (append obj blk))
(if obj
(progn
(setq tmp_blk (vla-insertblock
csp
(vlax-3d-point '(0. 0. 0.))
(vla-get-name unnamed_block)
1.0
1.0
1.0
0.0
)
)
(vla-GetBoundingBox tmp_blk 'MinPt 'MaxPt) ;_??????? ?????
(setq MinPt (vlax-safearray->list MinPt)
MaxPt (vlax-safearray->list MaxPt)
DS (max (distance MinPt (list (car MinPt) (cadr MaxPt)))
(distance MinPt (list (car MaxPt) (cadr MinPt)))
)
DS (* 0.2 DS) ;1/5
DS (max DS 10)
MinPt (mapcar '- MinPt (list DS DS))
MaxPt (mapcar '+ MaxPt (list DS DS))
)
(lib:Zoom2Lst (list MinPt MaxPt))
(setq sset (ssget "_C" MinPt MaxPt))
(if sset
(progn
(setvar "OSMODE" 0)
(setq hiden (mapcar 'vlax-ename->vla-object
(vl-remove-if
'listp
(mapcar 'cadr (ssnamex sset))
)
)
hiden (vl-remove tmp_blk hiden)
)
(mapcar '(lambda (x) (vla-put-Visible x :vlax-false))
hiden
)
(setq pt (mapcar '+ MinPt (list (* 0.5 DS) (* 0.5 DS))))
(vl-cmdf "_.RECTANG" (trans MinPt 0 1) (trans MaxPt 0 1))
(setq pl (vlax-ename->vla-object (entlast)))
(setq sc (1- (vla-get-count csp)))
(if
(VL-CATCH-ALL-ERROR-P
(VL-CATCH-ALL-APPLY
'(lambda ()
(vl-cmdf "_-BOUNDARY" (trans pt 0 1) "")
(while (> (getvar "CMDACTIVE") 0) (command ""))
)
)
)
(if isRus
(princ "\n?? ??????? ????????? ??????")
(princ "\n")
)
)
(setq ec (vla-get-count csp))
(while (list MiPt))
(list MiPt x)
)
ret
)
)
(setq ret (vl-sort ret
'(lambda (e1 e2)
(< (distance MinPt (car e1))
(distance MinPt (car e2))
)
)
)
)
(setq pl (nth 1 ret)
ret (vl-remove pl ret)
)
(mapcar 'vla-erase (mapcar 'cadr ret))
(mapcar '(lambda (x) (vla-put-Visible x :vlax-true))
hiden
)
(foreach x loc (vla-put-lock x :vlax-true))

(if isRus
(princ "\n?? ??????? ????????? ??????")
(princ "\n")
)

)
)
)
)
(VL-CATCH-ALL-APPLY
'(lambda ()
(mapcar 'vlax-release-object
(list unnamed_block tmp_blk csp blks lays)
)
)
)
)
) ;_if not
(foreach x loc (vla-put-lock x :vlax-true))
(setvar "OSMODE" osm)
(vla-endundomark adoc)
(vlax-release-object adoc)
(princ)
)

(defun c:blg ( / )
(while
(setq oldclayer (getvar "clayer"))
(command "-layer" "m" "0-BACKGROUND" "C" "42" "0-BACKGROUND" "")
(c:eco)
(c:pw)
(command "draworder" "L" "" "b")
(command "regenall")
(setvar "clayer" oldclayer)
)
)

Copy entities and paste it as block with user selected insertion point at once

30 Tuesday Oct 2018

Posted by danglar71 in Blocks, Utilites

≈ Leave a comment


;;; Copy entities and paste it as block with user selected insertion point at once
;;; Created by Igal Averbuh 2018

(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))
(princ "\nSelect insertion point of block:")
(setq pnt1 (getpoint))
(command "_.COPYBASE" pnt1 ss "")
(command "_.PASTEBLOCK" pnt1)
(command "_.ERASE" ss "")

(command "ucs" "previous")
(setvar "ucsicon" 1)
(setvar "cmdecho" 1)
(princ)

)
;(c:cpb)

Change Linetype of selected blocks entities and attributes to continuous

30 Thursday Aug 2018

Posted by danglar71 in Blocks

≈ Leave a comment


;;; Change Linetype of selected blocks entities and attributes to continuous
;;; Based on FIXBLOCK.LSP
;;; Modified by Igal Averbuh 2018

(defun d_FixBlock (/ eBlockSel ; Block selection
lInsertData ; Entity data
sBlockName ; Block name
lBlockData ; Entity data
eSubEntity ; Sub-entity name
lSubData ; Sub-entity data
iCount ; Counter
)

;; Redefine error handler

(setq
d_#error *error*
*error* d_FB_Error
) ;_ end setq

;; Set up environment

(setq #SYSVARS (#SaveSysVars (list "cmdecho")))

(setvar "cmdecho" 0)
(command "._undo" "_group")

;; Get block from user and make sure it's an INSERT type

(if (setq eBlockSel (entsel "\nSelect block to change :"))
(progn
(if (setq lInsertData (entget (car eBlockSel)))
(if (= (cdr (assoc 0 lInsertData)) "INSERT")
(setq sBlockName (cdr (assoc 2 lInsertData)))
(progn
(alert "Entity selected is not a block!")
(exit)
) ;_ end progn
) ;_ end if
(progn
(alert "Invalid Block Selection!")
(exit)
) ;_ end progn
) ;_ end if

;; Get block info from the block table

(setq
lBlockData (tblsearch "BLOCK" sBlockName)
eSubEntity (cdr (assoc -2 lBlockData))
) ;_ end setq

;; Make sure block is not an Xref

(if (not (assoc 1 lBlockData))
(progn
(princ "\nProcessing block: ")
(princ sBlockName)

(princ "\nUpdating blocks sub-entities. . .")

;; Parse through all of the blocks sub-entities

(while eSubEntity

(princ " .")
(setq lSubData (entget eSubEntity))

;; Update the linetype property

(if (assoc 6 lSubData)
(progn
(setq lSubData
(subst
(cons 6 "CONTINUOUS")
(assoc 6 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
(entmod (append lSubData (list (cons 6 "CONTINUOUS"))))
) ;_ end if

(setq eSubEntity (entnext eSubEntity))
; get next sub entity

) ; end while

;; Update attributes

(idc_FB_UpdAttribs)

) ; end progn
(alert "XREF selected. Not updated!")
) ; end if
) ; end progn
(alert "Nothing selected.")
) ; end if

;;; Pop error stack and reset environment

(idc_RestoreSysVars)

(princ "\nDone!")

(setq *error* d_#error)

(princ)

) ; end defun

;*******************************************************************************
; Function to update block attributes
;*******************************************************************************
(defun idc_FB_UpdAttribs ()

;; Update any attribute definitions

(setq iCount 0)

(princ "\nUpdating attributes. . .")
(if (setq ssInserts (ssget "x"
(list (cons 0 "INSERT")
(cons 66 1)
(cons 2 sBlockName)
) ;_ end list
) ;_ end ssget
) ;_ end setq
(repeat (sslength ssInserts)

(setq eBlockName (ssname ssInserts iCount))

(if (setq eSubEntity (entnext eBlockName))
(setq
lSubData (entget eSubEntity)
eSubType (cdr (assoc 0 lSubData))
) ;_ end setq
) ;_ end if

(while (or (= eSubType "ATTRIB") (= eSubType "SEQEND"))

;; Update the linetype property

(if (assoc 6 lSubData)
(progn
(setq lSubData
(subst
(cons 6 "CONTINUOUS")
(assoc 6 lSubData)
lSubData
) ;_ end subst
) ;_ end setq
(entmod lSubData)
) ;_ end progn
(entmod (append lSubData (list (cons 6 "CONTINUOUS"))))
) ;_ end if

(if (setq eSubEntity (entnext eSubEntity))
(setq
lSubData (entget eSubEntity)
eSubType (cdr (assoc 0 lSubData))
) ;_ end setq
(setq eSubType nil)
) ;_ end if

) ; end while

(setq iCount (1+ iCount))

) ; end repeat

) ; end if
(command "regen")
) ; end defun

;*******************************************************************************
; Function to save a list of system variables
;*******************************************************************************
(defun #SaveSysVars (lVarList / sSystemVar)
(mapcar
'(lambda (sSystemVar)
(setq lSystemVars
(append lSystemVars
(list (list sSystemVar (getvar sSystemVar)))
) ;_ end append
) ;_ end setq
) ;_ end lambda
lVarList
) ;_ end mapcar

lSystemVars

) ;_ end defun
;*******************************************************************************
; Function to restore a list of system variables
;*******************************************************************************
(defun idc_RestoreSysVars ()
(mapcar
'(lambda (sSystemVar)
(setvar (car sSystemVar) (cadr sSystemVar))
) ;_ end lambda
#SYSVARS
) ;_ end mapcar
) ;_ end defun
;*******************************************************************************
; Error Handler
;*******************************************************************************
(defun d_FB_Error (msg)

(princ "\nError occurred in the Fix Block routine...")
(princ "\nError: ")
(princ msg)

(setq *error* d_#error)
(if *error*
(*error* msg)
) ;_ end if

(command)

(if (/= msg "quit / exit abort")
(progn
(command "._undo" "_end")
(command "._u")
) ;_ end progn
) ;_ end if

(idc_RestoreSysVars)

(princ)

) ;_ end defun
;*******************************************************************************

(defun C:LX () (d_FixBlock))
(princ)

Replace selected blocks with a different one (replacing blocks and transferring attributes and some properties like layer, rotation and scale).

08 Sunday Apr 2018

Posted by danglar71 in Blocks, Utilites

≈ Leave a comment


;;; Replace selected blocks with a different one
;;;(replacing blocks and transferring attributes and some properties like layer, rotation and scale).
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-only-selected-blocks-with-a-different-one-lisp/td-p/6933210

(defun c:cbb(/ iCnt bSet cFlg nBlc cVal pLst
bNam aLst aDoc nBlc aSp cAt rLst)

(vl-load-com)

(defun Set_Initial_Setenv(varLst)
(mapcar
'(lambda(v)(if(not(getenv(car v)))(setenv(car v)(cadr v))))
varLst)
); end of Set_Initial_Setenv

(defun Unblock_All_Layers(/ aDoc layCol actLay outLst)
(setq aDoc(vla-get-ActiveDocument
(vlax-get-acad-object))
layCol(vla-get-Layers aDoc)
actLay(vla-get-ActiveLayer aDoc)
); end setq
(vlax-map-collection layCol
(function
(lambda(x)
(setq outLst
(cons
(list x
(vla-get-Lock x)
(vla-get-Freeze x)
)outLst)
); end setq
(vla-put-Lock x :vlax-false)
(if(not(equal x actLay))
(vla-put-Freeze x :vlax-false)
); end if
); end lambda
); end function
); end vlax-map-collection
outLst
); end of Unblock_All_Layers

(defun Restore_All_Layer_States(Lst / actLay)
(setq actLay(vla-get-ActiveLayer
(vla-get-ActiveDocument
(vlax-get-acad-object))))
(mapcar
(function
(lambda(x)
(vla-put-Lock(car x)(cadr x))
(if(not(equal actLay(car x)))
(vla-put-Freeze(car x)(last x))
); end if
)
)
Lst
)
(princ)
); end of Restore_All_Layer_States

(Set_Initial_Setenv '(("xchange:layer" "Yes")("xchange:scale" "Yes")
("xchange:rotation" "Yes")("xchange:attributes" "Yes")))
(princ "\n<<>> ")
(if(setq bSet(ssget '((0 . "INSERT"))))
(progn
(while(not cFlg)
(princ
(strcat "\nOptions: Layer = "(getenv "xchange:layer")
", Scale = " (getenv "xchange:scale")
", Rotation = " (getenv "xchange:rotation")
", Attributes = " (getenv "xchange:attributes")))
(initget "Options")
(setq nBlc(entsel "\nSelect new block or [Options] > "))
(cond
((and
(= 'LIST(type nBlc))
(equal '(0 . "INSERT")(assoc 0(entget(car nBlc))))
); end and
(setq nBlc(vlax-ename->vla-object(car nBlc))
cFlg T); end setq
); end condition #1
((= 'LIST(type nBlc))
(princ "\n This isn't block ")
); end condition #2
((= "Options" nBlc)
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block layer [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:layer" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block scale [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:scale" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block rotation [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:rotation" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit attributes with similar tags [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:attributes" cVal))
); end condition #3
); end cond
); end while
(setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object))
bNam(vla-get-Name nBlc)
aSp(vla-ObjectIdToObject aDoc(vla-get-OwnerId nBlc))
iCnt 0
); end setq
(vla-StartUndoMark aDoc)
(setq rLst(Unblock_All_Layers))
(foreach b(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp
(mapcar 'cadr(ssnamex bSet))))
(if(= :vlax-true(vla-get-HasAttributes b))
(setq aLst
(mapcar '(lambda (a)
(list (vla-get-TagString a)
(vla-get-TextString a)))
(vlax-safearray->list
(vlax-variant-value (vla-GetAttributes b)))))
); end if
(setq nBlc(vla-InsertBlock aSp (vla-get-InsertionPoint b)bNam 1.0 1.0 1.0 0.0))
(if(= "Yes"(getenv "xchange:layer"))
(vla-put-Layer nBlc(vla-get-Layer b))
); end if
(if(= "Yes"(getenv "xchange:scale"))
(progn
(vla-put-XScaleFactor nBlc(vla-get-XScaleFactor b))
(vla-put-YScaleFactor nBlc(vla-get-YScaleFactor b))
(vla-put-ZScaleFactor nBlc(vla-get-ZScaleFactor b))
); end progn
); end if
(if(= "Yes"(getenv "xchange:rotation"))
(vla-put-Rotation nBlc(vla-get-Rotation b))
); end if
(if
(and
(= "Yes"(getenv "xchange:attributes"))
(= :vlax-true(vla-get-HasAttributes nBlc))
); end and
(foreach i(mapcar '(lambda (a)(list(vla-get-TagString a)a))
(vlax-safearray->list
(vlax-variant-value(vla-GetAttributes nBlc))))
(if(setq cAt(assoc(car i)aLst))
(vla-put-TextString(last i)(last cAt))
); end if
); end foreach
); end if
;(vla-Delete b)
(setq iCnt(1+ iCnt))
); end foreach
(Restore_All_Layer_States rLst)
(vla-EndUndoMark aDoc)
(princ(strcat "\n" (itoa iCnt) " block(s) was replaced. "))
); end progn
(princ "\n Nothing selected " )
); end if
(princ)
);
(alert "\nMake select similar on All background blocks before invoke CBB")
(princ "\nType CBB to replace or add blocks")
(c:cbb)

Rotate North Block to Viewport WCS

25 Sunday Mar 2018

Posted by danglar71 in Blocks, Layouts, Utilites

≈ Leave a comment


;;; Rotate North Block to Viewport WCS
;;; Created by: Lee Mac
;;; Saved from: https://www.theswamp.org/index.php?topic=54008.0

(defun c:nar ( / ent obj sel )
(if (= 1 (getvar 'cvport))
(progn
(while
(progn (setvar 'errno 0) (princ "\nSelect a viewport: ")
(not
(or (setq sel (ssget "_+.:E:S" '((0 . "VIEWPORT"))))
(= 52 (getvar 'errno))
)
)
)
(princ "\nMissed, try again.")
)
(if sel
(while
(progn
(setvar 'errno 0)
(setq ent (car (entsel "\nSelect north arrow: ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (null ent) nil)
( (/= "INSERT" (cdr (assoc 0 (entget ent))))
(princ "\nThe selected object is not a block.")
)
( (not (vlax-write-enabled-p (setq obj (vlax-ename->vla-object ent))))
(princ "\nThe selected block is on a locked layer.")
)
( (vla-put-rotation obj (cdr (assoc 51 (entget (ssname sel 0))))))
)
)
)
)
)
(princ "\nCommand only available in Paperspace.")
)
(princ)
)
(vl-load-com) (princ)
(c:nar)

Isolate Blocks by Layer

21 Wednesday Mar 2018

Posted by danglar71 in Blocks, Layers

≈ Leave a comment


(vl-load-com)

(defun c:LIO ( / _pac :GetBlocksLayersSS ss new temp en i i2 lst lays)

;; Based on routine written by Alan J. Thompson, 03.31.11
;; http://www.cadtutor.net/forum/showthread.php?57864-How-to-select-all-objects-enclosed-in-a-poly-line&p=392378&viewfull=1#post392378
;; Modified by Igal Averbuh 2018 (added option to restore previous layer state after nested layer isolation)
(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))) 100.))))
(while ( (cdr (assoc 62 (tblsearch "layer" (getvar 'clayer)))) 0)
(setvar 'clayer "0")
(setvar 'clayer (car lst)))

(command "expert" "0")
))
(princ)
;(alert "Use LUO to restore Current Layer State")
)
;(c:lio)

(defun c:LUO (/)
(if (layerstate-has "_LAYISOCUR_STATE")
(progn
(layerstate-restore "_LAYISOCUR_STATE")
(layerstate-delete "_LAYISOCUR_STATE")
)
(print "There's no layer state to restore.")
)
(princ)
)

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)

← Older posts

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