• 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: Utilites

Draw “Heat Grid” (Lee Mac)

03 Tuesday Mar 2020

Posted by danglar71 in Utilites

≈ 2 Comments


;;; Saved from: https://www.cadtutor.net/forum/topic/43738-a-challenge-how-to-draw-this-floor-heating/
;;----------------------------=={ Heat Grid }==-------------------------;;
;; ;;
;; Prompts the user to select a rectangular closed LWPolyline and ;;
;; specify a grid wire spacing, and proceeds to construct a maximised ;;
;; filleted spiral centered within the selected LWPolyline based on ;;
;; the given wire spacing. ;;
;; ;;
;; The program will perform successfully with rectangular LWPolylines ;;
;; at any rotation or orientation, and with all UCS & Views. ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2013 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;

(defun c:hg ( / 2pi a1 a2 bl d2 di en h1 h2 ix l1 l2 l3 mt no p1 p2 pi2 rm tv v1 vl w1 w2 zv )
(setq pi2 (/ pi 2.0)
2pi (+ pi pi)
)
(while
(progn
(setvar 'errno 0)
(setq en (car (entsel "\nSelect Rectangular Closed LWPolyline: ")))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (= 'ename (type en))
(if (null (LM:rectangle-p en))
(princ "\nObject must be a Rectangular Closed LWPolyline.")
)
)
)
)
)
(if (= 'ename (type en))
(progn
(setq vl
(apply 'append
(mapcar
(function
(lambda ( dx )
(if (= 10 (car dx))
(list (trans (cdr dx) en 1))
)
)
)
(entget en)
)
)
)
(setq a1 (angle (car vl) (cadr vl))
w1 (distance (car vl) (cadr vl))
h1 (distance (cadr vl) (caddr vl))
)
(if (< h1 w1)
(setq tv w1
w1 h1
h1 tv
a1 (+ a1 pi2)
)
)
(setq w2 w1
h2 h1
)
(while
(and
(progn
(initget 6)
(setq di
(getdist
(strcat "\nSpecify Wire Spacing"
(if *spacing* (strcat " : ") ": ")
)
)
)
(if (null di)
(setq di *spacing*)
(setq *spacing* di)
)
)
(progn
(setq no (fix (/ w2 di))
rm (rem w2 di)
)
(if (equal 0.0 rm 0.1)
(setq no (1- no)
rm (+ rm di)
)
)
(if (zerop (rem no 2))
(setq no (1- no)
rm (+ rm di)
)
)
(< no 2)
)
)
(princ "\nWire Spacing too large.")
)
(if (= 'real (type di))
(progn
(setq w2 (- w2 rm)
h2 (- h2 rm)
p1 (list (/ rm 2.0) (/ rm 2.0) 0.0)
l1 (list p1)
a2 pi2
ix 0
)
(repeat no
(setq p1 (polar p1 a2 (if (zerop (rem ix 2)) h2 w2))
l1 (cons p1 l1)
a2 (rem (- a2 pi2) 2pi)
ix (1+ ix)
)
(if (and (< 2 ix) (= 1 (rem ix 2)))
(setq w2 (- w2 di di)
h2 (- h2 di di)
)
)
)
(setq l1 (reverse l1)
w2 (- w1 rm di di)
h2 (- h1 rm di)
p1 (list (+ (/ rm 2.0) di) (/ rm 2.0) 0.0)
l2 (list p1)
a2 pi2
ix 0
)
(repeat (- no 2)
(setq p1 (polar p1 a2 (if (zerop (rem ix 2)) h2 w2))
l2 (cons p1 l2)
a2 (rem (- a2 pi2) 2pi)
ix (1+ ix)
)
(if (= ix 2)
(setq h2 (- h2 di))
(if (and (< 2 ix) (= 1 (rem ix 2)))
(setq w2 (- w2 di di)
h2 (- h2 di di)
)
)
)
)
(setq
v1
(mapcar '- (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) (car vl) (caddr vl))
(setq p2
(apply 'mapcar
(cons (function (lambda ( a b ) (/ (+ a b) 2.0)))
(mapcar
(function
(lambda ( x ) (apply 'mapcar (cons x l1)))
)
'(min max)
)
)
)
)
)
d2 (/ di 2.0)
bl (/ (sin (/ pi -8.0)) (cos (/ pi 8.0)))
l1
(apply 'append
(mapcar
(function
(lambda ( a b c )
(cond
( (null a)
(list b)
)
( (null c)
(list (polar b (angle b a) d2))
)
( (list (polar b (angle b a) d2) bl (polar b (angle b c) d2)))
)
)
)
(cons nil l1)
l1
(append (cdr l1) '(nil))
)
)
bl (- bl)
l2
(apply 'append
(mapcar
(function
(lambda ( a b c )
(cond
( (null a)
(list (polar b (angle b c) d2))
)
( (null c)
(list b)
)
( (list (polar b (angle b a) d2) bl (polar b (angle b c) d2)))
)
)
)
(cons nil l2)
l2
(append (cdr l2) '(nil))
)
)
zv (trans '(0.0 0.0 1.0) 1 0 t)
mt (list (list (cos a1) (- (sin a1))) (list (sin a1) (cos a1)))
v1 (mapcar '+ v1 (mapcar '- p2 (mxv mt p2)))
l3
(mapcar
(function
(lambda ( x )
(if (listp x)
(cons 10 (trans (mapcar '+ (mxv mt x) v1) 1 zv))
(cons 42 x)
)
)
)
(append l1 (list -1.0 (polar (last l1) (+ a2 pi) di) (polar (car l2) a2 di) 1.0) l2)
)
)
(entmake
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 090 (length (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) l3)))
'(070 . 0)
(cons 210 zv)
)
l3
)
)
)
)
)
)
(princ)
)

;; Rectangle-p - Lee Mac
;; Returns T if the supplied entity is a rectangular closed LWPolyline

(defun LM:rectangle-p ( e / a b c d )
(and
(= "LWPOLYLINE" (cdr (assoc 0 (setq e (entget e)))))
(= 4 (cdr (assoc 90 e)))
(= 1 (logand 1 (cdr (assoc 70 e))))
(LM:nobulge-p e)
(mapcar 'set '(a b c d)
(apply 'append
(mapcar '(lambda ( x ) (if (= 10 (car x)) (list (cdr x)))) e)
)
)
(LM:perp-p (mapcar '- a b) (mapcar '- a d))
(LM:perp-p (mapcar '- a b) (mapcar '- b c))
(LM:perp-p (mapcar '- a d) (mapcar '- c d))
)
)

;; Perpendicular-p - Lee Mac
;; Returns T if the supplied vectors are perpendicular

(defun LM:perp-p ( u v )
(equal 0.0 (apply '+ (mapcar '* u v)) 1e-8)
)

;; No Bulge-p - Lee Mac
;; Returns T if the supplied LWPolyline DXF list has zero bulge

(defun LM:nobulge-p ( e / p )
(or (not (setq p (assoc 42 e)))
(and (equal 0.0 (cdr p) 1e-8)
(LM:nobulge-p (cdr (member p e)))
)
)
)

;; 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
(strcat
"\n:: HeatGrid.lsp | Version 1.0 | © Lee Mac "
(menucmd "m=$(edtime,$(getvar,DATE),YYYY)")
" http://www.lee-mac.com ::"
"\n:: Type \"hg\" to Invoke ::"
)
)
(princ)

;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
(c:hg)

PROGRAM FOR SPRINKLER DISTRIBUTION

25 Tuesday Feb 2020

Posted by danglar71 in Lisp Collection 2014, Utilites

≈ Leave a comment


;;; Sprinkler Distribution Program
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/sprinkler-spaces/td-p/9335919
;;; Need to insert PENDANT sprinkler block named "spr" into drawing
;;; or UPRIGHT sprinkler block named "spu"

(setvar 'cmdecho 0)
(command "_.layer" "_make" "M-FIRE-SYMB-P" "_color" "1" "" "")
(setvar 'cmdecho 1)
(vl-load-com)

(defun SS ; = Sprinkler Spacing
(blkname / *error* ssia doc svnames svvals v1 rectss n ucschanged v3)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); if
(if ucschanged (command-s "_.ucs" "_previous"))
; [change to (command ... if Acad version predates (command-s) function]
(mapcar 'setvar svnames svvals); reset System Variables
(vla-endundomark doc)
(princ)
); defun - *error*

(defun ssia ; = SS Insert & Array
(/ delta LL nLong longEdge spcMax spcLong spcShortTemp
nShort shortEdge spcShort longX nX nY spcX spcY)
(setq
delta (reverse (cdr (reverse (mapcar 'abs (mapcar '- v3 v1)))))
; XY [only] differences list
LL (mapcar 'min v1 v3)
; Lower Left regardless of pick order or Pline start or direction
nLong
(+
(fix (/ (setq longEdge (apply 'max delta)) (setq spcMax (cadr (assoc haz hazlist)))))
; rounded-down longer dimension divided by base max. spacing
(if (= (rem longEdge spcMax) 0) 0 1); round up if any remainder
); + & nLong
spcLong (/ longEdge nLong); spacing in long direction
spcShortTemp (/ (caddr (assoc haz hazlist)) spcLong)
; max. area div. by long-direction spacing
nShort
(+
(fix (/ (setq shortEdge (apply 'min delta)) spcShortTemp))
; rounded-down shorter dimension divided by max. spacing
(if (= (rem shortEdge spcShortTemp) 0) 0 1); round up if any remainder
); + & nShort
); setq
(while (> (setq spcShort (/ shortEdge nShort)) spcMax)
; spacing in short direction, compared to maximum spacing
(setq nShort (1+ nShort))
); while
(setq
longX (apply '> delta); is it longer in X dimension?
nX (if longX nLong nShort); number in X direction
spcX (if longX spcLong spcShort); spacing in X direction
nY (if longX nShort nLong)
spcY (if longX spcShort spcLong)
); setq
(command
"_.insert" blkname "_none" (mapcar '+ LL (list (/ spcX 2) (/ spcY 2))) "" "" ""
"_.array" "_last" "" "_r" nY nX
); command [leaves in Array command at prompt for spacing(s)]
(cond
((= nX 1) (command spcY))
((= nY 1) (command spcX))
(T (command spcY spcX))
); cond
); defun -- ssia

(vla-startundomark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
(setq ; System Variable saving/resetting without separate variables for each:
svnames '(cmdecho ucsfollow osmode blipmode)
svvals (mapcar 'getvar svnames)
); setq
(mapcar 'setvar svnames '(0 0)); turn off command echoing, UCS follow
(initget 1 "Light Ordinary Extra"); 1 = no Enter
(setq
hazlist
'(
("Combustible" 460 210000) ("Non-Combustible" 460 180000); Light subtypes
("Ordinary" 460 120000) ("Extra" 370 90000)
)
haz (getkword "\nSpecify Space Hazard Type [Light/Ordinary/Extra]: ")
); setq
(if (= haz "Light")
(progn
(initget 1 "Combustible Non-Combustible")
(setq haz (getkword "\nLight Hazard subtype [Combustible/Non-combustible]: "))
); progn
); if
(initget "Select"); allows S as input to (getpoint) function, instead of point pick
(setq v1 (getpoint "\nFirst Corner of rectangular area for Sprinklers, or [Select]: "))
; [if in non-World UCS, returns in current UCS coordinates, not in WCS]
(if (= v1 "Select"); chose that option
(progn ; then
(prompt "\nTo distribute Sprinklers in rectangular Polylines,")
(if (setq rectss (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&") (70 . 1))))
; multiple selection -- only 4-vertex closed [does not check for rectangularity]
(progn ; then
(mapcar 'setvar svnames '(0 0 0 0)); also turn off Osnap, blips
(repeat (setq n (sslength rectss)); step through selection
(setq rect (ssname rectss (setq n (1- n))))
(command "_.ucs" "_object" rect)
(setq
ucschanged T ; marker for resetting in *error*
v1 (trans (vlax-curve-getPointAtParam rect 0) 0 1); starting vertex
v3 (trans (vlax-curve-getPointAtParam rect 2) 0 1); third vertex [opposite corner]
); setq
(ssia); run the subroutine to Insert and Array
(command "_.ucs" "_previous")
(setq ucschanged nil); [turn off marker]
); repeat
); progn
(prompt "\nNo closed 4-vertex Polyline(s) selected."); else
); if
); progn
(progn ; else [picked a point]
(setq v3 (getcorner v1 "\nOpposite Corner: "))
(mapcar 'setvar svnames '(0 0 0 0)); also turn off Osnap, blips
(ssia); run the subroutine to Insert & Array
); progn
); if
(mapcar 'setvar svnames svvals); reset System Variables
(vla-endundomark doc)
(princ)
); defun -- SS

(defun C:SSP ()
(SS "SPR")
); defun

(defun C:SSU ()
(SS "SPU")
); defun

(prompt "\n THIS PROGRAM FOR SPRINKLER DISTRIBUTION ")
(prompt "\n START command by : SSP:PENDANT SSU:UPRIGHT ")
(prompt "\n\n CREATED by :\n ********* M.SAIED. ********* ")
(prompt "\n MODIFIED by :\n ********* Saber Elkassas & Kent Cooper. ********* ")
(princ)

Make “Paper” background mask for selected texts

31 Thursday Oct 2019

Posted by danglar71 in Text, Utilites

≈ 2 Comments


(vl-load-com)

; Required ExpressTools

(defun c:TM ( / *error* sel ss sst i enl sse con)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
(princ (strcat "\nError: " errmsg)))
(mapcar 'setvar *BG-VAR* *BG-VAL*)
(setq *BG-doc* nil *BG-VAR* nil *BG-VAL* nil *BG-enl* nil)
(princ))

;(princ "\nSelect Background color:\n\n")
;(setq col (acad_colordlg 7))

(setvar 'OFFSETDIST
(cond ((getdist (strcat "\nSpecify Background width by 2 points on screen : ")))
((getvar 'OFFSETDIST))
)
)

(if (and (setq sel (ssget "_:L" '((0 . "*TEXT"))))
(setq *BG-enl* (entlast))
(setq ss (ssadd))
)

(progn

(vla-startundomark (setq *BG-doc* (vla-get-activedocument (vlax-get-acad-object))))
(setq *BG-VAL* (mapcar 'getvar (setq *BG-VAR* '(CMDECHO OSMODE CLAYER DELOBJ PEDITACCEPT PICKSTYLE))))
(mapcar 'setvar *BG-VAR* '(0 0 "0" 3 1 0))

(setq enl (entlast))
(command "_.COPY" sel "" '(0 0 0) '(0 0 0))
(while (setq enl (entnext enl))
(ssadd enl ss))

(if (setq sst (acet-ss-ssget-filter ss (list (cons 0 (strcat "*LEADER,DIMENSION")))))
(progn
(initcommandversion)
(command "_.EXPLODE" sst ""))) ; creates new lwpolylines,lines,*text,solid,insert

(if (setq sst (acet-ss-ssget-filter ss (list (cons 0 (strcat "INSERT")))))
(LM:burstsel sst t)) ; creates new lwpolylines,lines,*text,solid

(setq enl *BG-enl* ss (ssadd))
(while (setq enl (entnext enl))
(if (entget enl) (ssadd enl ss))) ; revised ss - cleared from removed ents and added new ones

(if (setq sst (acet-ss-ssget-filter ss '((0 . "SOLID")))) ; creates new lwpolylines (flat)
(repeat (setq i (sslength ss))
(:solid2polyline (ssname ss (setq i (1- i))))))

(if (setq sst (acet-ss-ssget-filter ss '((0 . "CIRCLE"))))
(:circle2polyline sst)) ; creates new lwpolylines

(if (setq sst (acet-ss-ssget-filter ss '((0 . "SPLINE"))))
(repeat (setq i (sslength sst))
(command "_.SPLINEDIT" (ssname sst (setq i (1- i))) "_Polyline" 10))) ; creates new lwpolylines

(if (setq sst (acet-ss-ssget-filter ss '((0 . "LINE,ARC"))))
(command "_.PEDIT" "_Multiple" sst "" "")) ; lwpolylines

(setq enl *BG-enl* ss (ssadd))
(while (setq enl (entnext enl))
(if (entget enl) (ssadd enl ss))) ; revised ss - cleard of removed ents and added new ones

(if (setq sst (acet-ss-ssget-filter ss '((0 . "*POLYLINE"))))
(command "_.PEDIT" "_Multiple" sst "" "_Width" (getvar 'OFFSETDIST) ""))

(if (setq sst (acet-ss-ssget-filter ss '((0 . "*TEXT"))))
(progn
(acet-setvar (list "acet_textmask_masktype" "Solid" 3)) ; Save the mask type
(acet-setvar (list "acet_textmask_maskcolor" col 3)) ; and the color
(sssetfirst nil sst)
(vla-sendcommand *BG-doc* (strcat "TEXTMASK\rP\r\r\r\r(BackgroundFinish)\r\r" (chr 27))))
(BackgroundFinish))

))
(princ)
)

; ---------------------------------------------------------------------------- 2ND PART OF MAIN ROUTINE BECAUSE OF VLA-SENDCOMMAND MUST BE THE LAST

(defun BackgroundFinish (/ *error* ss sst enl)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break,end"))
(princ (strcat "\nError: " errmsg)))
(mapcar 'setvar *BG-VAR* *BG-VAL*)
(vla-endundomark *BG-doc*)
(setq *BG-doc* nil *BG-VAR* nil *BG-VAL* nil *BG-enl* nil)
(princ))

; ----

(if *BG-enl*
(progn

(setq enl *BG-enl* ss (ssadd))
(while (setq enl (entnext enl))
(if (entget enl) (ssadd enl ss)))

(command "_.-LAYER" "_T" "0-BACKGROUND" "_U" "0-BACKGROUND" "_M" "0-BACKGROUND" "_C" "T" "255,255,255" "0-BACKGROUND" ""
"_.CHPROP" ss "" "_Layer" "0-BACKGROUND" "_LType" "_ByLayer" "_Color" "_ByLayer" ""
"_.DRAWORDER" ss "" "_Back"
"_.REGENALL")

(if (setq sst (acet-ss-ssget-filter ss '((-4 . ""))))
(command "_.ERASE" sst ""))

(*error* "end")))
(princ)
)

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

;; beeekeecz

(defun :solid2polyline (ent / lst lay)

(if (and ent
(= "SOLID" (cdr (assoc 0 (entget ent))))
(setq lst (mapcar '(lambda (y) (reverse (cdr (reverse (cdr y)))))
(vl-remove-if-not '(lambda (x) (vl-position (car x) '(10 11 12 13))) (entget ent))))
(setq lst (if (equal (nth 2 lst) (nth 3 lst) 1e-6) ; its triangle
(reverse (cdr (reverse lst)))
(list (nth 0 lst) (nth 1 lst) (nth 3 lst) (nth 2 lst))))
(setq lay (assoc 8 (entget ent)))
(entdel ent)
)
(entmakex (append (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 (length lst))
(cons 70 1)
lay)
(mapcar (function (lambda (p) (cons 10 p))) lst)))))

;; Written by Kent Cooper
;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/circle-to-polyline-circular-polyline-to-circle/m-p/5520233/highlight/true#M330236
;; Mods by BeekeeCZ to make it subfunc

(defun :circle2polyline (csel / conv cir cdata cctr crad pdata ssnew)

(if (and csel ; User selection
(setq ssnew (ssadd)))
(repeat (sslength csel); then
(setq cir (ssname csel 0); Circle entity name
cdata (entget cir); entity data
cctr (cdr (assoc 10 cdata)); center point, OCS for Circle & LWPolyline w/ WCS 0,0,0 as origin
crad (cdr (assoc 40 cdata)); radius
pdata (vl-remove-if-not '(lambda (x) (member (car x) '(67 410 8 62 6 48 370 39))) cdata)
; start Polyline entity data list -- remove Circle-specific entries from
; Circle's entity data, and extrusion direction; 62 Color, 6 Linetype, 48
; LTScale, 370 LWeight, 39 Thickness present only if not default/bylayer
); setq
(ssadd (entmakex (append '((0 . "LWPOLYLINE")
(100 . "AcDbEntity"))
pdata ; remaining non-entity-type-specific entries
(list '(100 . "AcDbPolyline")
'(90 . 2); # of vertices
(cons 70 (1+ (* 128 (getvar 'plinegen)))); closed [the 1], and uses
; current linetype-generation setting; change above line to
; '(70 . 129) to force linetype generation on, '(70 . 1) to force it off
'(43 . 0.0); global width
(cons 38 (caddr cctr)); elevation in OCS above WCS origin [Z of Circle center]
(cons 10 (list (- (car cctr) crad) (cadr cctr))); vertex 1
'(40 . 0.0) '(41 . 0.0) '(42 . 1); 0 start & end widths, semi-circle bulge factor
(cons 10 (list (+ (car cctr) crad) (cadr cctr))); vertex 2
'(40 . 0.0) '(41 . 0.0) '(42 . 1)
(assoc 210 cdata) ; extr. dir. at end [if in middle, reverts to (210 0.0 0.0 1.0) in (entmake)]
)))
ssnew)
(ssdel cir csel)
(entdel cir)))
ssnew)

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

;;------------------------=={ Burst Upgraded }==------------------------;;
;; ;;
;; This program operates in much the same way as the familiar ;;
;; Express Tools' Burst command, however invisible block attributes ;;
;; are not displayed with the resulting exploded components. ;;
;; ;;
;; Following a valid selection of blocks to burst, the program ;;
;; converts all visible single-line & multi-line attributes into Text ;;
;; and MText respectively, before proceeding to explode the block, ;;
;; and deleting the original attribute objects. ;;
;; ;;
;; The core function accepts a selection set argument and may hence ;;
;; be called from within other custom programs to burst all blocks ;;
;; in a supplied selection set. ;;
;; ;;
;; The methods used by the program should also perform much faster & ;;
;; more efficiently than those used by the Express Tools' Burst.lsp. ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2010 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.0 - 2010-11-25 ;;
;; ;;
;; - First release. ;;
;;----------------------------------------------------------------------;;
;; Version 1.1 - 2013-08-29 ;;
;; ;;
;; - Program entirely rewritten. ;;
;;----------------------------------------------------------------------;;
;; Version 1.2 - 2014-02-23 ;;
;; ;;
;; - Program restructured to accept selection set argument. ;;
;; - Program now also explodes non-attributed blocks. ;;
;;----------------------------------------------------------------------;;
;; Version 1.3 - 2015-10-31 ;;
;; ;;
;; - Program modified to account for non-uniformly scaled blocks. ;;
;; - Command syntax changed to 'myburst'. ;;
;;----------------------------------------------------------------------;;
;; Version 1.4 - 2018-01-06 ;;
;; ;;
;; - Program modified to retain visible constant attributes. ;;
;; - Corrected LM:usblock-p function to account for mirrored blocks. ;;
;;----------------------------------------------------------------------;;
;; Version 1.5 - 2018-07-09 ;;
;; ;;
;; - Accounted for multiline attributes whose text content occupies ;;
;; multiple group 1 & 3 DXF groups. ;;
;;----------------------------------------------------------------------;;
;; Version 1.6 - 2018-12-10 ;;
;; ;;
;; - Accounted for invisible objects created when bursting dynamic ;;
;; blocks with visibility states. ;;
;; - Fixed bug causing attributes with transparency to be removed. ;;
;; - Integrated Nested Burst program. ;;
;;----------------------------------------------------------------------;;
;; Version 1.7 - 2018-12-22 ;;
;; ;;
;; - Accounted for nested xrefs (excluding them from burst operation). ;;
;;----------------------------------------------------------------------;;

(defun c:pburst nil (LM:burst nil))
(defun c:nburst nil (LM:burst t))

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

(defun LM:burst ( nst / *error* )

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

(LM:startundo (LM:acdoc))
(LM:burstsel
(LM:ssget "\nSelect blocks to burst: "
(list "_:L"
(append '((0 . "INSERT"))
(
(lambda ( / def lst )
(while (setq def (tblnext "block" (null def)))
(if (= 4 (logand 4 (cdr (assoc 70 def))))
(setq lst (vl-list* "," (cdr (assoc 2 def)) lst))
)
)
(if lst (list '(-4 . "")))
)
)
(if (= 1 (getvar 'cvport))
(list (cons 410 (getvar 'ctab)))
'((410 . "Model"))
)
)
)
)
nst
)
(LM:endundo (LM:acdoc)) (princ)
)

(defun LM:burstsel ( sel nst / idx )
(if (= 'pickset (type sel))
(repeat (setq idx (sslength sel))
(LM:burstobject (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))) nst)
)
)
)

(defun LM:burstobject ( obj nst / cmd col ent err lay lin lst qaf tmp )
(if
(and
(= "AcDbBlockReference" (vla-get-objectname obj))
(not (vlax-property-available-p obj 'path))
(vlax-write-enabled-p obj)
(or (and (LM:usblock-p obj)
(not (vl-catch-all-error-p (setq err (vl-catch-all-apply 'vlax-invoke (list obj 'explode)))))
(setq lst err)
)
(progn
(setq tmp (vla-copy obj)
ent (LM:entlast)
cmd (getvar 'cmdecho)
qaf (getvar 'qaflags)
)
(setvar 'cmdecho 0)
(setvar 'qaflags 0)
(vl-cmdf "_.explode" (vlax-vla-object->ename tmp))
(setvar 'qaflags qaf)
(setvar 'cmdecho cmd)
(while (setq ent (entnext ent))
(setq lst (cons (vlax-ename->vla-object ent) lst))
)
lst
)
)
)
(progn
(setq lay (vla-get-layer obj)
col (vla-get-color obj)
lin (vla-get-linetype obj)
)
(foreach att (vlax-invoke obj 'getattributes)
(if (vlax-write-enabled-p att)
(progn
(if (= "0" (vla-get-layer att))
(vla-put-layer att lay)
)
(if (= acbyblock (vla-get-color att))
(vla-put-color att col)
)
(if (= "byblock" (strcase (vla-get-linetype att) t))
(vla-put-linetype att lin)
)
)
)
(if
(and
(= :vlax-false (vla-get-invisible att))
(= :vlax-true (vla-get-visible att))
)
( (if (and (vlax-property-available-p att 'mtextattribute) (= :vlax-true (vla-get-mtextattribute att)))
LM:burst:matt2mtext
LM:burst:att2text
)
(entget (vlax-vla-object->ename att))
)
)
)
(foreach new lst
(cond
( (not (vlax-write-enabled-p new)))
( (= :vlax-false (vla-get-visible new))
(vla-delete new)
)
( t
(if (= "0" (vla-get-layer new))
(vla-put-layer new lay)
)
(if (= acbyblock (vla-get-color new))
(vla-put-color new col)
)
(if (= "byblock" (strcase (vla-get-linetype new) t))
(vla-put-linetype new lin)
)
(if (= "AcDbAttributeDefinition" (vla-get-objectname new))
(progn
(if
(and
(= :vlax-true (vla-get-constant new))
(= :vlax-false (vla-get-invisible new))
)
( (if (and (vlax-property-available-p new 'mtextattribute) (= :vlax-true (vla-get-mtextattribute new)))
LM:burst:matt2mtext
LM:burst:att2text
)
(entget (vlax-vla-object->ename new))
)
)
(vla-delete new)
)
(if nst (LM:burstobject new nst))
)
)
)
)
(vla-delete obj)
)
)
)

(defun LM:burst:removepairs ( itm lst )
(vl-remove-if '(lambda ( x ) (member (car x) itm)) lst)
)

(defun LM:burst:remove1stpairs ( itm lst )
(vl-remove-if '(lambda ( x ) (if (member (car x) itm) (progn (setq itm (vl-remove (car x) itm)) t))) lst)
)

(defun LM:burst:att2text ( enx )
(entmakex
(append '((0 . "TEXT"))
(LM:burst:removepairs '(000 002 003 070 074 100 280 440)
(subst (cons 73 (cdr (assoc 74 enx))) (assoc 74 enx) enx)
)
)
)
)

(defun LM:burst:matt2mtext ( enx )
(entmakex
(append '((0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText"))
(LM:burst:remove1stpairs
(if (= "ATTDEF" (cdr (assoc 0 enx)))
'(001 003 007 010 040 041 050 071 072 073 210)
'(001 007 010 040 041 050 071 072 073 210)
)
(LM:burst:removepairs '(000 002 011 042 043 051 070 074 100 101 102 280 330 360 440) enx)
)
(list (assoc 011 (reverse enx)))
)
)
)

;; Uniformly Scaled Block - Lee Mac
;; Returns T if the supplied VLA Block Reference is uniformly scaled
;; obj - [vla] VLA Block Reference

(defun LM:usblock-p ( obj / s )
(if (vlax-property-available-p obj 'xeffectivescalefactor)
(setq s "effectivescalefactor")
(setq s "scalefactor")
)
(eval
(list 'defun 'LM:usblock-p '( obj )
(list 'and
(list 'equal
(list 'abs (list 'vlax-get-property 'obj (strcat "x" s)))
(list 'abs (list 'vlax-get-property 'obj (strcat "y" s)))
1e-8
)
(list 'equal
(list 'abs (list 'vlax-get-property 'obj (strcat "x" s)))
(list 'abs (list 'vlax-get-property 'obj (strcat "z" s)))
1e-8
)
)
)
)
(LM:usblock-p obj)
)

;; entlast - Lee Mac
;; A wrapper for the entlast function to return the last subentity in the database

(defun LM:entlast ( / ent tmp )
(setq ent (entlast))
(while (setq tmp (entnext ent)) (setq ent tmp))
ent
)

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

;;----------------------------------------------------------------------;;
;; End of File ;;
;;----------------------------------------------------------------------;;
(c:tm)

Draw closed polyline and hatch within it by solid hatch with “paper background” color and draworder all xrefs back

01 Sunday Sep 2019

Posted by danglar71 in draw, Utilites

≈ Leave a comment


;;; Draw closed polyline and hatch within it by solid hatch with "paper background" color and draworder all xrefs back
;;; Created by Igal Averbuh 2019
;;; Based on Lee Mak and Charles Alan Butler routines

;;;====================================================================;
;;; SetCurrent.lsp ;
;;; Charles Alan Butler ;
;;; ab2draft@TampaBay.rr.com ;
;;; @ Copyright 2005 ;
;;; Original routine 2003 ;
;;;====================================================================;
;;
;; Revision 06/17/04
;; Revision 06/28/04
;; Added Leader detection & layer change for any object selected.
;; Revision 07/03/04
;; Added cross check for leader to text & text to leader
;;
;; Routine to set current Layer, Text Style and/or Dim Style by
;; picking an existing object in the drawing
;;
;; OBJECT SELECTED Set Current
;; TEXT, MTEXT or Rtext Layer, Text Style
;; Dimension Layer, Dim Style
;; Leader Layer, Dim Style
;; Leader w/text Layer, Dim & Text Style
;; Text, mtext w/Leader Layer, Dim & Text Style
;; Any other object Layer
;;
;; Enter tds from the command line to run
;; or set up a menu button with ^C^Ctds
;;
;;;====================================================================;
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;
;;;====================================================================;
;;; Copyright 2005 by Charles Alan Butler. All Rights Reserved. ;
;;; ;
;;; You are hereby granted permission to use, copy and modify this ;
;;; software without charge, provided you do so exclusively for ;
;;; your own use or for use by others in your organization in the ;
;;; performance of their normal duties, and provided further that ;
;;; the above copyright notice appears in all copies and both that ;
;;; copyright notice and the limited warranty and restricted rights ;
;;; notice below appear in all supporting documentation. ;
;;; ;
;;; Incorporation of any part of this software into other software, ;
;;; except when such incorporation is exclusively for your own use ;
;;; or for use by others in your organization in the performance of ;
;;; their normal duties, is prohibited without the prior written ;
;;; consent of Charles Alan Butler, 1403 Duelda Drive, ;
;;; Brandon Florida, 33511 ;
;;; ;
;;; Copying, modification and distribution of this software or any ;
;;; part thereof in any form except as expressly provided herein is ;
;;; prohibited without the prior written consent of Charles Alan ;
;;; Butler, 1403 Duelda Drive, Brandon Florida, 33511 ;
;;; ;
;;;====================================================================;
(defun c:tds (/ ent entbl t:styold t:stynew d:styold d:stynew usercmd
idx x )
(defun set:dim:style (elst)
(setq d:styold (getvar "dimstyle"))
(command "-dimstyle" "restore" (cdr (assoc 3 elst)))
(setq d:stynew (getvar "dimstyle"))
)
(defun set:txt:style (elst)
(setq t:stynew (cdr (assoc 7 elst))
t:styold (getvar "textstyle")
)
(setvar "TextSize" (cdr (assoc 40 elst)))
(setvar "TextStyle" t:stynew)
)
;; ************** Begin Routine ******************
(if (setq ent
(car (entsel "\nSelect Object to make layer current (Enter to None): "))
)
(progn
(setq entbl (entget ent)) ; Get entity definition list
(setq usercmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "undo" "begin")
(cond
;; ============================================================
((= (cdr (assoc 0 entbl)) "LEADER") ; found a leader
(setvar 'clayer (cdr (assoc 8 entbl)))
(set:dim:style entbl); Set Dim Style Current
(cond ; chek to see if text is attched
((and (setq elst (entget(cdr (assoc 340 entbl))))
(wcmatch (cdr (assoc 0 elst)) "*TEXT*"))
(set:txt:style elst); Set TextStyle Current
)
)
); end cond 1

;; ===========================================================
((wcmatch (cdr (assoc 0 entbl)) "*TEXT*") ; gets Rtext as well
(set:txt:style entbl); Set TextStyle Current
(setvar 'clayer (cdr (assoc 8 entbl)))
;; Look for leader to set dim Style Current
(setq idx (length entbl))
(while (> (setq idx (1- idx))-1)
(setq ent (nth idx entbl))
(cond
((and (= (car ent) 330) ; pointer to leader
(setq elst (entget (cdr ent))) ; valid ent ??
(= (cdr (assoc 0 elst)) "LEADER"))
(set:dim:style entbl); Set Dim Style Current
(setq idx 0); 0 = exit loop
); cond
); cond stmt
); while
) ; end cond 2

;; =============================================================
((= (cdr (assoc 0 entbl)) "DIMENSION")
(set:dim:style entbl); Set Dim Style Current
(setvar 'clayer (cdr (assoc 8 entbl)))
) ; end cond 3

;; =============================================================
(t ; catch any other object
(and (cdr (assoc 8 entbl))
(setvar 'clayer (cdr (assoc 8 entbl)))
)
) ; end cond (T)

) ; end Cond stmt
;; *************** Display Changes Made *******************
(prompt (strcat "\n*-* Object selected: " (cdr (assoc 0 entbl))))
(and (cdr (assoc 8 entbl))
(prompt (strcat "\n*-* Layer changed to: " (cdr (assoc 8 entbl)))))
(if d:styold
(prompt (strcat "\n*-* Dimension style changed: "
d:styold " to "
d:stynew "."
)
)
)
(if t:styold
(prompt
(strcat "\n*-* Text style changed: " t:styold " to " t:stynew ".")
)
)
(setq t:stynew nil
t:styold nil
d:stynew nil
d:styold nil
)

(command "undo" "end")
(setvar "CMDECHO" usercmd)
) ; end progn
) ; endif
(princ)
) ;End of Defun
;(prompt "\nText / Dimension Style Changer Loaded, Type TDS to run")
(princ)

(defun c:raa ( / nv oc p1 p2 p3 p4 p5 pl p5a os AScol ASsize )
(if
(and
(setq p1 (getpoint "\n1st point: "))
(setq p2 (getpoint "\n2nd point: " p1))
)
(progn
(setq nv (trans (mapcar '- p2 p1) 1 0 t)
oc (trans '(0.0 0.0 1.0) 1 0 t)
p3 (trans p1 1 nv)
p4 (trans p2 1 nv)
)

;AutoSnap marker color
(setq AScol (LM:OLE->RGB (atoi (getenv "Model AutoSnap Color"))))
(setq AScol (LM:RGB->ACI (car AScol) (cadr AScol) (caddr AScol)))

;AutoSnap marker size
(setq ASsize (* (atoi (getenv "AutoSnapSize")) 0.002))

(princ "\n3rd point: ")
(while (= 5 (car (setq p5 (grread t 13 0))))
(redraw)
(and (setq os (osmode2str)) (setq p5a (osnap (cadr p5) os)))
(if p5a
(progn
(ASvector p5a AScol)
(setq p5a (trans p5a 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5a) (cadr p5a) (caddr p4)) nv 1)
(trans (list (car p5a) (cadr p5a) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
(progn
(setq p5 (trans (cadr p5) 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5) (cadr p5) (caddr p4)) nv 1)
(trans (list (car p5) (cadr p5) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
)
)
(if
(and
(listp (cadr p5))
(setq p5 (trans (cadr p5) 1 nv))
)
(progn
(and p5a (setq p5 p5a))
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans p1 1 oc))
(cons 010 (trans p2 1 oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p4)) nv oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p3)) nv oc))
(cons 210 oc)
)
)
)
)
(redraw)
)
)
(princ)
)

;----------------------------------------------------------
; Return the current osnap mode in the form of a string.
; i.e.: osmode = 37 --> "_end,_cen,_int"
; Gian Paolo Cattaneo - 09/11/2013
;----------------------------------------------------------
(defun osmode2str ( / osm)
(if (> (getvar 'osmode) 0)
(mapcar
'(lambda (a b)
(if (= a (logand a (getvar 'osmode)))
(if osm
(setq osm (strcat osm "," b))
(setq osm b)
)
)
)
'(1 2 4 8 16 32 64 128 256 512)
'("_end" "_mid" "_cen" "_nod" "_qua"
"_int" "_ins" "_per" "_tan" "_nea"
)
)
)
osm
)

;----------------------------------------------------------
;; OLE -> RGB - Lee Mac 2011
;; Args: c - OLE Colour
;----------------------------------------------------------
(defun LM:OLE->RGB ( c )
(list
(lsh (lsh (fix c) 24) -24)
(lsh (lsh (fix c) 16) -24)
(lsh (lsh (fix c) 8) -24)
)
)

;----------------------------------------------------------
;; RGB -> ACI - Lee Mac 2011
;; Args: r,g,b - Red,Green,Blue values
;----------------------------------------------------------
(defun LM:RGB->ACI ( r g b / cObj aci ) (vl-load-com)
(if
(and
(setq cObj
(vla-getInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-SetRGB (list cObj r g b))
)
)
)
(setq aci (vla-get-ColorIndex cObj))
)
(if cObj (vlax-release-object cObj))
aci
)

;_____________________credit: ronjonp______________________
(defun ASvector (pt: color / L L- c1 c2 *1 *2 *3 *4 *5 *6
*7 *8 *9 *10 *11 *12)
(setq L (* (* 1.3 ASsize) (getvar 'viewsize))
L- (* 0.9 L)
c1 (polar pt: pi (* L 0.06))
c2 (polar pt: 0.0 (* L 0.06))
*1 (polar c1 0.785 L)
*2 (polar c1 2.356 L-)
*3 (polar c1 3.926 L-)
*4 (polar c1 5.498 L)
*5 (polar c2 0.785 L-)
*6 (polar c2 2.356 L)
*7 (polar c2 3.926 L)
*8 (polar c2 5.498 L-)
*9 (polar pt: 0.785 L)
*10 (polar pt: 2.356 L)
*11 (polar pt: 3.926 L)
*12 (polar pt: 5.498 L)
)
(grvecs (list color *2 *5 *3 *8 *6 *7 *1 *4))
(grvecs (list color *9 *10 *11 *12 *9 *12 *10 *11))
(grvecs (list color *1 *3 *2 *4 *5 *7 *6 *8 *9 *11 *10 *12))
)

;;************

(defun c:cross (/ )

(command "-hatch" "p" "s" "")
(command "-hatch" "s" "l" "" "p" "s" "co" "t" "255,255,255" "" )
(command "draworder" "l" "" "b")
(c:os)

);defun
(princ)

(DEFUN c:xrb ( / curent curset newset)
(vl-load-com)
(command "._TILEMODE" "1")
(SETQ newset (SSADD))
(IF (SETQ curset (SSGET "X" '((0 . "INSERT"))))
(WHILE (SETQ curent (SSNAME curset 0))
(SETQ curobj (VLAX-ENAME->VLA-OBJECT curent))
(IF (= T (VLAX-PROPERTY-AVAILABLE-P curobj 'path))
(SSADD curent newset)
)
(SSDEL curent curset)
)
)
(command "_.draworder" newset "" "_b")
)

(defun c:phx ( / hpn )
(setq hpn (getvar 'hpname))
(setvar 'hpname "SOLID")
(command "_.pline")
(while (< 0 (getvar 'cmdactive)) (command "\\"))
(command "_.-BHATCH" "_S" (ssadd (entlast)))
(while (< 0 (getvar 'cmdactive)) (command ""))
(setvar 'hpname hpn)
(princ)
(command "_.change" "L" "" "P" "C" "T" "255,255,255" "")
(command "_.draworder" "L" "" "B")
)

(defun c:ph ( )
(setvar "osmode" 0)
(c:tds)
(setvar "osmode" 0)
(c:phx)
;(setvar "osmode" 0)
;(c:cross)
(setvar "osmode" 0)
(c:xrb)
(setvar "osmode" 167)
)
(c:ph)

Draw closed polyline and wipeout it with draworder all xrefs back

01 Sunday Sep 2019

Posted by danglar71 in draw, Utilites

≈ Leave a comment


;;; Draw closed polyline and wipeout it with draworder all xrefs back
;;; Created by Igal Averbuh 2019
;;; Based on Lee Mak and Charles Alan Butler routines

;;;====================================================================;
;;; SetCurrent.lsp ;
;;; Charles Alan Butler ;
;;; ab2draft@TampaBay.rr.com ;
;;; @ Copyright 2005 ;
;;; Original routine 2003 ;
;;;====================================================================;
;;
;; Revision 06/17/04
;; Revision 06/28/04
;; Added Leader detection & layer change for any object selected.
;; Revision 07/03/04
;; Added cross check for leader to text & text to leader
;;
;; Routine to set current Layer, Text Style and/or Dim Style by
;; picking an existing object in the drawing
;;
;; OBJECT SELECTED Set Current
;; TEXT, MTEXT or Rtext Layer, Text Style
;; Dimension Layer, Dim Style
;; Leader Layer, Dim Style
;; Leader w/text Layer, Dim & Text Style
;; Text, mtext w/Leader Layer, Dim & Text Style
;; Any other object Layer
;;
;; Enter tds from the command line to run
;; or set up a menu button with ^C^Ctds
;;
;;;====================================================================;
;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED ;
;;; WARRANTY. ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR ;
;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED. ;
;;;====================================================================;
;;; Copyright 2005 by Charles Alan Butler. All Rights Reserved. ;
;;; ;
;;; You are hereby granted permission to use, copy and modify this ;
;;; software without charge, provided you do so exclusively for ;
;;; your own use or for use by others in your organization in the ;
;;; performance of their normal duties, and provided further that ;
;;; the above copyright notice appears in all copies and both that ;
;;; copyright notice and the limited warranty and restricted rights ;
;;; notice below appear in all supporting documentation. ;
;;; ;
;;; Incorporation of any part of this software into other software, ;
;;; except when such incorporation is exclusively for your own use ;
;;; or for use by others in your organization in the performance of ;
;;; their normal duties, is prohibited without the prior written ;
;;; consent of Charles Alan Butler, 1403 Duelda Drive, ;
;;; Brandon Florida, 33511 ;
;;; ;
;;; Copying, modification and distribution of this software or any ;
;;; part thereof in any form except as expressly provided herein is ;
;;; prohibited without the prior written consent of Charles Alan ;
;;; Butler, 1403 Duelda Drive, Brandon Florida, 33511 ;
;;; ;
;;;====================================================================;
(defun c:tds (/ ent entbl t:styold t:stynew d:styold d:stynew usercmd
idx x )
(defun set:dim:style (elst)
(setq d:styold (getvar "dimstyle"))
(command "-dimstyle" "restore" (cdr (assoc 3 elst)))
(setq d:stynew (getvar "dimstyle"))
)
(defun set:txt:style (elst)
(setq t:stynew (cdr (assoc 7 elst))
t:styold (getvar "textstyle")
)
(setvar "TextSize" (cdr (assoc 40 elst)))
(setvar "TextStyle" t:stynew)
)
;; ************** Begin Routine ******************
(if (setq ent
(car (entsel "\nSelect Object to make layer current (Enter to None): "))
)
(progn
(setq entbl (entget ent)) ; Get entity definition list
(setq usercmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "undo" "begin")
(cond
;; ============================================================
((= (cdr (assoc 0 entbl)) "LEADER") ; found a leader
(setvar 'clayer (cdr (assoc 8 entbl)))
(set:dim:style entbl); Set Dim Style Current
(cond ; chek to see if text is attched
((and (setq elst (entget(cdr (assoc 340 entbl))))
(wcmatch (cdr (assoc 0 elst)) "*TEXT*"))
(set:txt:style elst); Set TextStyle Current
)
)
); end cond 1

;; ===========================================================
((wcmatch (cdr (assoc 0 entbl)) "*TEXT*") ; gets Rtext as well
(set:txt:style entbl); Set TextStyle Current
(setvar 'clayer (cdr (assoc 8 entbl)))
;; Look for leader to set dim Style Current
(setq idx (length entbl))
(while (> (setq idx (1- idx))-1)
(setq ent (nth idx entbl))
(cond
((and (= (car ent) 330) ; pointer to leader
(setq elst (entget (cdr ent))) ; valid ent ??
(= (cdr (assoc 0 elst)) "LEADER"))
(set:dim:style entbl); Set Dim Style Current
(setq idx 0); 0 = exit loop
); cond
); cond stmt
); while
) ; end cond 2

;; =============================================================
((= (cdr (assoc 0 entbl)) "DIMENSION")
(set:dim:style entbl); Set Dim Style Current
(setvar 'clayer (cdr (assoc 8 entbl)))
) ; end cond 3

;; =============================================================
(t ; catch any other object
(and (cdr (assoc 8 entbl))
(setvar 'clayer (cdr (assoc 8 entbl)))
)
) ; end cond (T)

) ; end Cond stmt
;; *************** Display Changes Made *******************
(prompt (strcat "\n*-* Object selected: " (cdr (assoc 0 entbl))))
(and (cdr (assoc 8 entbl))
(prompt (strcat "\n*-* Layer changed to: " (cdr (assoc 8 entbl)))))
(if d:styold
(prompt (strcat "\n*-* Dimension style changed: "
d:styold " to "
d:stynew "."
)
)
)
(if t:styold
(prompt
(strcat "\n*-* Text style changed: " t:styold " to " t:stynew ".")
)
)
(setq t:stynew nil
t:styold nil
d:stynew nil
d:styold nil
)

(command "undo" "end")
(setvar "CMDECHO" usercmd)
) ; end progn
) ; endif
(princ)
) ;End of Defun
;(prompt "\nText / Dimension Style Changer Loaded, Type TDS to run")
(princ)

(defun c:raa ( / nv oc p1 p2 p3 p4 p5 pl p5a os AScol ASsize )
(if
(and
(setq p1 (getpoint "\n1st point: "))
(setq p2 (getpoint "\n2nd point: " p1))
)
(progn
(setq nv (trans (mapcar '- p2 p1) 1 0 t)
oc (trans '(0.0 0.0 1.0) 1 0 t)
p3 (trans p1 1 nv)
p4 (trans p2 1 nv)
)

;AutoSnap marker color
(setq AScol (LM:OLE->RGB (atoi (getenv "Model AutoSnap Color"))))
(setq AScol (LM:RGB->ACI (car AScol) (cadr AScol) (caddr AScol)))

;AutoSnap marker size
(setq ASsize (* (atoi (getenv "AutoSnapSize")) 0.002))

(princ "\n3rd point: ")
(while (= 5 (car (setq p5 (grread t 13 0))))
(redraw)
(and (setq os (osmode2str)) (setq p5a (osnap (cadr p5) os)))
(if p5a
(progn
(ASvector p5a AScol)
(setq p5a (trans p5a 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5a) (cadr p5a) (caddr p4)) nv 1)
(trans (list (car p5a) (cadr p5a) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
(progn
(setq p5 (trans (cadr p5) 1 nv))
(mapcar '(lambda ( a b ) (grdraw a b 1 1))
(setq pl
(list p1 p2
(trans (list (car p5) (cadr p5) (caddr p4)) nv 1)
(trans (list (car p5) (cadr p5) (caddr p3)) nv 1)
)
)
(cons (last pl) pl)
)
)
)
)
(if
(and
(listp (cadr p5))
(setq p5 (trans (cadr p5) 1 nv))
)
(progn
(and p5a (setq p5 p5a))
(entmake
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(090 . 4)
'(070 . 1)
(cons 010 (trans p1 1 oc))
(cons 010 (trans p2 1 oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p4)) nv oc))
(cons 010 (trans (list (car p5) (cadr p5) (caddr p3)) nv oc))
(cons 210 oc)
)
)
)
)
(redraw)
)
)
(princ)
)

;----------------------------------------------------------
; Return the current osnap mode in the form of a string.
; i.e.: osmode = 37 --> "_end,_cen,_int"
; Gian Paolo Cattaneo - 09/11/2013
;----------------------------------------------------------
(defun osmode2str ( / osm)
(if (> (getvar 'osmode) 0)
(mapcar
'(lambda (a b)
(if (= a (logand a (getvar 'osmode)))
(if osm
(setq osm (strcat osm "," b))
(setq osm b)
)
)
)
'(1 2 4 8 16 32 64 128 256 512)
'("_end" "_mid" "_cen" "_nod" "_qua"
"_int" "_ins" "_per" "_tan" "_nea"
)
)
)
osm
)

;----------------------------------------------------------
;; OLE -> RGB - Lee Mac 2011
;; Args: c - OLE Colour
;----------------------------------------------------------
(defun LM:OLE->RGB ( c )
(list
(lsh (lsh (fix c) 24) -24)
(lsh (lsh (fix c) 16) -24)
(lsh (lsh (fix c) 8) -24)
)
)

;----------------------------------------------------------
;; RGB -> ACI - Lee Mac 2011
;; Args: r,g,b - Red,Green,Blue values
;----------------------------------------------------------
(defun LM:RGB->ACI ( r g b / cObj aci ) (vl-load-com)
(if
(and
(setq cObj
(vla-getInterfaceObject (vlax-get-acad-object)
(strcat "AutoCAD.AcCmColor." (substr (getvar 'ACADVER) 1 2))
)
)
(not
(vl-catch-all-error-p
(vl-catch-all-apply 'vla-SetRGB (list cObj r g b))
)
)
)
(setq aci (vla-get-ColorIndex cObj))
)
(if cObj (vlax-release-object cObj))
aci
)

;_____________________credit: ronjonp______________________
(defun ASvector (pt: color / L L- c1 c2 *1 *2 *3 *4 *5 *6
*7 *8 *9 *10 *11 *12)
(setq L (* (* 1.3 ASsize) (getvar 'viewsize))
L- (* 0.9 L)
c1 (polar pt: pi (* L 0.06))
c2 (polar pt: 0.0 (* L 0.06))
*1 (polar c1 0.785 L)
*2 (polar c1 2.356 L-)
*3 (polar c1 3.926 L-)
*4 (polar c1 5.498 L)
*5 (polar c2 0.785 L-)
*6 (polar c2 2.356 L)
*7 (polar c2 3.926 L)
*8 (polar c2 5.498 L-)
*9 (polar pt: 0.785 L)
*10 (polar pt: 2.356 L)
*11 (polar pt: 3.926 L)
*12 (polar pt: 5.498 L)
)
(grvecs (list color *2 *5 *3 *8 *6 *7 *1 *4))
(grvecs (list color *9 *10 *11 *12 *9 *12 *10 *11))
(grvecs (list color *1 *3 *2 *4 *5 *7 *6 *8 *9 *11 *10 *12))
)

;;************

(defun c:cross1 (/ )

(command "wipeout" "p" "l" "y")

(command "draworder" "l" "" "b")
(c:os)

);defun
(princ)

(DEFUN c:xrb ( / curent curset newset)
(vl-load-com)
(command "._TILEMODE" "1")
(SETQ newset (SSADD))
(IF (SETQ curset (SSGET "X" '((0 . "INSERT"))))
(WHILE (SETQ curent (SSNAME curset 0))
(SETQ curobj (VLAX-ENAME->VLA-OBJECT curent))
(IF (= T (VLAX-PROPERTY-AVAILABLE-P curobj 'path))
(SSADD curent newset)
)
(SSDEL curent curset)
)
)
(command "_.draworder" newset "" "_b")
)

(defun c:whx ( / hpn )

(setvar "osmode" 167)

(command "_.pline")
(while (< 0 (getvar 'cmdactive)) (command "\\"))

(command "wipeout" "p" (ssadd (entlast)) "y")

(while (< 0 (getvar 'cmdactive)) (command ""))

(princ)
(command "draworder" "l" "" "b")
)

(defun c:pw ( )
(setvar "osmode" 0)
(c:tds)
(setvar "osmode" 0)
(c:whx)
(setvar "osmode" 0)
(c:xrb)
(setvar "osmode" 167)
)
(c:pw)

Offset Nested Lines and Polylines in a one click change it width and convert it to red color

29 Thursday Aug 2019

Posted by danglar71 in Utilites

≈ Leave a comment


;;; Offset Nested Lines and Polylines in a one click change it width and convert it to red color
;;; Modified by Igal Averbuh 2019 (added option to change width of ncopied polylines + offset by Kent Cooper subroutine)
;;; Inspired by dbhunia and Kent Cooper subrroutines
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/ncopy-multiple-elements-and-convert-them-to-cyan-color/td-p/8301579
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/offset-last-entity/td-p/2604367

(defun c:no (/ lastent ss)
(setq lastent (entlast))
(setq ss (ssadd))
(command "_.ncopy")
(while (> (getvar "cmdactive") 0)
(command pause "0,0" "0,0")
)
(while (setq lastent (entnext lastent))
(ssadd lastent ss)

)
(command "chprop" ss "" "C" 1 "")
(command "pedit" "m" ss "" "w" 0.15 "")
(setq ent (entlast))

(command
"_.offset"
"T"
ent
pause ; select side
""
)
(entdel ent)
)

Creating table with selected text

21 Wednesday Aug 2019

Posted by danglar71 in Lisp Collection 2014, Utilites

≈ Leave a comment


;;; Creating table with selected text
;;; Created by sea.haven
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-for-creating-table-with-selected-text/td-p/8954787
;;; Slightly modified by Igal Averbuh 2019 (added option fo set text size by 2 points on screen)

(defun c:mtl ( / pt1 numrows numcolumns rowheight colwidth ent doc curspace obj objtable col)
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(setq curspace (vla-get-modelspace doc))
; now do table
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table: ")))
(setq numcolumns (getint "\nHow many columns..."))
(setq numrows 2)
(setq txtsz (getdist "\nEnter text size by 2 points on screen..."))

(setq rowheight (* 1.5 txtsz))
(setq colwidth (* 10 txtsz))
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "TABLE")
(setq x 1)
(repeat numcolumns
(vla-settext objtable 1 (- x 1) (strcat "COLUMN " (rtos x 2 0)))
(setq x (+ x 1))
)

(setq objtable (vlax-ename->vla-object (entlast)))
(vla-InsertRows objtable numrows txtsz 1)
(setq col 0)
(while (setq ent (entsel "pick text object"))
(setq obj (vlax-ename->vla-object (car ent)))
(if (= (vla-get-objectname obj) "AcDbText")
(progn
(vla-settext objtable numrows col (vla-get-textstring obj))
(setq col (+ col 1))
(if (= col numcolumns)
(progn
(setq col 0)
(setq numrows (+ numrows 1))
(vla-InsertRows objtable numrows (* txtsz 1.5) 1)
)
)
)
)
)

(vla-SetTextHeight objtable (+ acDataRow acHeaderRow acTitleRow) txtsz)
(vla-SetAlignment objtable acDataRow acMiddleCenter)
(vlax-release-object objtable)
(princ)
)

(c:mtl)

Viewport Outline V1.3: adds two new commands: VPOL – Outline all viewports in the active Paperspace layout; VPOA – Outline all viewports in all Paperspace layouts.

20 Tuesday Aug 2019

Posted by danglar71 in Utilites, Vport

≈ Leave a comment


;;-----------------------=={ Viewport Outline }==-----------------------;;
;; ;;
;; This program allows the user to automatically generate a polyline ;;
;; in modelspace representing the outline of a selected paperspace ;;
;; viewport. ;;
;; ;;
;; The command is only available in paperspace (that is, when a ;;
;; layout tab other than the Model tab is the current layout, and no ;;
;; viewports are active). ;;
;; ;;
;; Upon issuing the command syntax 'VPO' at the AutoCAD command-line, ;;
;; the user is prompted to select a viewport for which to construct ;;
;; the viewport outline in modelspace. ;;
;; ;;
;; Following a valid selection, the boundary of the selected viewport ;;
;; is transformed appropriately to account for the position, scale, ;;
;; rotation, & orientation of the modelspace view displayed through ;;
;; the selected viewport, and a 2D polyline (LWPolyline) representing ;;
;; this transformed boundary is constructed in modelspace. ;;
;; ;;
;; The program is compatible for use with all Rectangular, Polygonal & ;;
;; Clipped Viewports (including those with Arc segments), and with all ;;
;; views & construction planes. ;;
;; ;;
;; The program also offers the ability to optionally offset the ;;
;; polyline outline to the interior of the viewport boundary by a ;;
;; predetermined number of paperspace units specified in the ;;
;; 'Program Parameters' section of the program source code. ;;
;; ;;
;; The program may also be configured to automatically apply a ;;
;; predefined set of properties (e.g. layer, colour, linetype, etc.) ;;
;; to the resulting polyline outline - these properties are also ;;
;; listed within the 'Program Parameters' section of the source code. ;;
;; ;;
;;----------------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2015 - http://www.lee-mac.com ;;
;;----------------------------------------------------------------------;;
;; Version 1.0 - 2015-01-02 ;;
;; ;;
;; - First release. ;;
;;----------------------------------------------------------------------;;
;; Version 1.1 - 2016-08-11 ;;
;; ;;
;; - Program modified to account for polygonal viewports represented ;;
;; by 2D (Heavy) Polylines. ;;
;;----------------------------------------------------------------------;;
;; Version 1.2 - 2017-09-03 ;;
;; ;;
;; - Added the ability to specify an optional interior offset ;;
;; (relative to Paperspace Viewport dimensions). ;;
;; - Added default polyline properties. ;;
;;----------------------------------------------------------------------;;
;; Version 1.3 - 2019-08-12 ;;
;; ;;
;; - Restructured program as a main function accepting a viewport ;;
;; entity argument. ;;
;; - Added two additional custom commands: ;;
;; - 'vpol' - outlines all viewports in the active Paperspace layout ;;
;; - 'vpoa' - outlines all viewports in all Paperspace layouts ;;
;;----------------------------------------------------------------------;;

;;----------------------------------------------------------------------;;
;; VPO - Outline a selected viewport in the active Paperspace layout ;;
;;----------------------------------------------------------------------;;

(defun c:vpo ( / *error* sel )

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

(LM:startundo (LM:acdoc))
(cond
( (/= 1 (getvar 'cvport))
(princ "\nCommand not available in Modelspace.")
)
( (setq sel (LM:ssget "\nSelect viewport: " '("_+.:E:S" ((0 . "VIEWPORT")))))
(vpo:main (ssname sel 0))
)
)
(LM:endundo (LM:acdoc))
(princ)
)

;;----------------------------------------------------------------------;;
;; VPOL - Outline all viewports in the active Paperspace layout ;;
;;----------------------------------------------------------------------;;

(defun c:vpol ( / *error* idx sel )

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

(cond
( (/= 1 (getvar 'cvport))
(princ "\nCommand not available in Modelspace.")
)
( (setq sel (ssget "_X" (list '(0 . "VIEWPORT") '(-4 . "") '(69 . 1) (cons 410 (getvar 'ctab)))))
(LM:startundo (LM:acdoc))
(repeat (setq idx (sslength sel))
(vpo:main (ssname sel (setq idx (1- idx))))
)
(LM:endundo (LM:acdoc))
)
( (princ "\nNo viewports were found in the active layout."))
)
(princ)
)

;;----------------------------------------------------------------------;;
;; VPOA - Outline all viewports in all Paperspace layouts ;;
;;----------------------------------------------------------------------;;

(defun c:vpoa ( / *error* idx sel )

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

(cond
( (setq sel (ssget "_X" '((0 . "VIEWPORT") (-4 . "") (69 . 1) (410 . "~Model"))))
(LM:startundo (LM:acdoc))
(repeat (setq idx (sslength sel))
(vpo:main (ssname sel (setq idx (1- idx))))
)
(LM:endundo (LM:acdoc))
)
( (princ "\nNo viewports were found in any Paperspace layouts."))
)
(princ)
)

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

(defun vpo:main ( vpt / cen dpr ent lst ltp ocs ofe off tmp vpe )

(setq

;;----------------------------------------------------------------------;;
;; Program Parameters ;;
;;----------------------------------------------------------------------;;

;; Optional Interior Offset
;; Set this parameter to nil or 0.0 for no offset
off 0.0

;; Default Polyline Properties
;; Omitted properties will use current settings when the program is run
dpr
'(
(006 . "BYLAYER") ;; Linetype (must be loaded)
;(008 . "VPOutline") ;; Layer (automatically created if not present in drawing)
(039 . 0.0) ;; Thickness
(048 . 1.0) ;; Linetype Scale
(062 . 256) ;; Colour (0 = ByBlock, 256 = ByLayer)
(370 . -1) ;; Lineweight (-1 = ByLayer, -2 = ByBlock, -3 = Default, 0.3 = 30 etc.)
)

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

)

(if (setq vpt (entget vpt)
ent (cdr (assoc 340 vpt))
)
(setq lst (vpo:polyvertices ent))
(setq cen (mapcar 'list (cdr (assoc 10 vpt))
(list
(/ (cdr (assoc 40 vpt)) 2.0)
(/ (cdr (assoc 41 vpt)) 2.0)
)
)
lst (mapcar '(lambda ( a ) (cons (mapcar 'apply a cen) '(42 . 0.0))) '((- -) (+ -) (+ +) (- +)))
)
)
(if (not (LM:listclockwise-p (mapcar 'car lst)))
(setq lst (reverse (mapcar '(lambda ( a b ) (cons (car a) (cons 42 (- (cddr b))))) lst (cons (last lst) lst))))
)
(if (and (numberp off) (not (equal 0.0 off 1e-8)))
(cond
( (null
(setq tmp
(entmakex
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
'(070 . 1)
)
(apply 'append (mapcar '(lambda ( x ) (list (cons 10 (car x)) (cdr x))) lst))
)
)
)
)
(princ "\nUnable to generate Paperspace outline for offset.")
)
( (vl-catch-all-error-p (setq ofe (vl-catch-all-apply 'vlax-invoke (list (vlax-ename->vla-object tmp) 'offset off))))
(princ (strcat "\nViewport dimensions too small to offset outline by " (rtos off) " units."))
(entdel tmp)
)
( (setq ofe (vlax-vla-object->ename (car ofe))
lst (vpo:polyvertices ofe)
)
(entdel ofe)
(entdel tmp)
)
)
)
(setq vpe (cdr (assoc -1 vpt))
ocs (cdr (assoc 16 vpt))
)
(entmakex
(append
(list
'(000 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
'(070 . 1)
'(410 . "Model")
)
(if (and (setq ltp (assoc 6 dpr)) (not (tblsearch "ltype" (cdr ltp))))
(progn
(princ (strcat "\n\"" (cdr ltp) "\" linetype not loaded - linetype set to \"ByLayer\"."))
(subst '(6 . "BYLAYER") ltp dpr)
)
dpr
)
(apply 'append (mapcar '(lambda ( x ) (list (cons 10 (trans (pcs2wcs (car x) vpe) 0 ocs)) (cdr x))) lst))
(list (cons 210 ocs))
)
)
)

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

(defun vpo:polyvertices ( ent )
(apply '(lambda ( foo bar ) (foo bar))
(if (= "LWPOLYLINE" (cdr (assoc 0 (entget ent))))
(list
(lambda ( enx )
(if (setq enx (member (assoc 10 enx) enx))
(cons (cons (cdr (assoc 10 enx)) (assoc 42 enx)) (foo (cdr enx)))
)
)
(entget ent)
)
(list
(lambda ( ent / enx )
(if (= "VERTEX" (cdr (assoc 0 (setq enx (entget ent)))))
(cons (cons (cdr (assoc 10 enx)) (assoc 42 enx)) (foo (entnext ent)))
)
)
(entnext ent)
)
)
)
)

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

;; List Clockwise-p - Lee Mac
;; Returns T if the point list is clockwise oriented

(defun LM:listclockwise-p ( lst )
(minusp
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
lst (cons (last lst) lst)
)
)
)
)

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

;; PCS2WCS (gile)
;; Translates a PCS point to WCS based on the supplied Viewport
;; (PCS2WCS pt vp) is the same as (trans (trans pt 3 2) 2 0) when vp is active
;; pnt : PCS point
;; ent : Viewport ename

(defun PCS2WCS ( pnt ent / ang enx mat nor scl )
(setq pnt (trans pnt 0 0)
enx (entget ent)
ang (- (cdr (assoc 51 enx)))
nor (cdr (assoc 16 enx))
scl (/ (cdr (assoc 45 enx)) (cdr (assoc 41 enx)))
mat (mxm
(mapcar (function (lambda ( v ) (trans v 0 nor t)))
'( (1.0 0.0 0.0)
(0.0 1.0 0.0)
(0.0 0.0 1.0)
)
)
(list
(list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
)
)
(mapcar '+
(mxv mat
(mapcar '+
(vxs pnt scl)
(vxs (cdr (assoc 10 enx)) (- scl))
(cdr (assoc 12 enx))
)
)
(cdr (assoc 17 enx))
)
)

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

;; Vector x Scalar - Lee Mac
;; Args: v - vector in R^n, s - real scalar

(defun vxs ( v s )
(mapcar '(lambda ( n ) (* n s)) v)
)

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

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

(princ
(strcat
"\n:: VPOutline.lsp | Version 1.3 | \\U+00A9 Lee Mac "
((lambda ( y ) (if (= y (menucmd "m=$(edtime,0,yyyy)")) y (strcat y "-" (menucmd "m=$(edtime,0,yyyy)")))) "2015")
" http://www.lee-mac.com ::"
"\n:: \"vpo\" - Outline single viewport ::"
"\n:: \"vpol\" - Outline all viewports in active layout ::"
"\n:: \"vpoa\" - Outline all viewports in all layouts ::"
)
)
(princ)

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

Locates and marks the ends of arcs, lines, and polylines that are close but not exactly coincident

31 Wednesday Jul 2019

Posted by danglar71 in Utilites

≈ Leave a comment

 

 

 

;| Locates and marks the ends of arcs, lines, and plines that are close
but not exactly coincident. Gaps are marked by drawing circles on the GAP layer.
You can select part of a drawing to check or press ENTER to check the whole drawing.
These are the distances to control how the gaps are located
Gap Limit = Gaps less than this, but more than fluff are marked
Fluff = Gaps less than this are not marked
Circle Size = Size of circle to mark gaps with
Original routine by McNeel & Associates
-----------------------------------------------------------------------
-----------------------------------------------------------------------
Modified by J. Tippit, SPAUG President 12/29/98
E-mail: cadpres@spaug.org
Web Site: http://www.spaug.org
-----------------------------------------------------------------------
-----------------------------------------------------------------------
Revisions:
12/29/98 Added ability to change Gap Limit, Fluff, & Circle Size
Added CMDECHO, UNDO, OSMODE, & CURLAY
Added a counter for the number of cicles that are drawn
and other misc. prompts
Changed the Gap layer to be RED
-----------------------------------------------------------------------
|;

;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/find-and-mark-gaps-lisp-repair/td-p/5934951

(defun dxf (x e) (cdr (assoc x e)))
; Removes entities other than line, pline, arc from a selection set
(defun checkss (ss / i)
(setq i (sslength ss))
(while (> i 0)
(setq i (1- i))
(setq ent (entget (ssname ss i)))
(or
(= "LINE" (dxf 0 ent))
(= "POLYLINE" (dxf 0 ent))
(= "ARC" (dxf 0 ent))
(ssdel (ssname ss i) ss)
)
)
(if (> (sslength ss) 0)
ss
)
)
; Returns the endpoints of lines, arcs and pines
(defun endsofent (ent / v e1 e2)
(cond
((= "LINE" (dxf 0 ent))
(list (dxf 10 ent) (dxf 11 ent))
)
((= "ARC" (dxf 0 ent))
(list
(polar (dxf 10 ent) (dxf 50 ent) (dxf 40 ent))
(polar (dxf 10 ent) (dxf 51 ent) (dxf 40 ent))
)
)
((= "POLYLINE" (dxf 0 ent))
(setq v (entget (entnext (dxf -1 ent))))
(setq e1 (dxf 10 v))
(while (/= "SEQEND" (dxf 0 v))
(setq e2 (dxf 10 v))
(setq v (entget (entnext (dxf -1 v))))
)
(list e1 e2)
)
)
)
; gets a selection set of all entities near a point
(defun ssat (pt dist)
(ssget "c"
(list (- (car pt) dist) (- (cadr pt) dist))
(list (+ (car pt) dist) (+ (cadr pt) dist))
)
)
; Looks through a selection set and finds ends near but not at ends
; of other entities
(defun markgaps (ss / i ends)
(setq i (sslength ss))
(while (> i 0)
(setq i (1- i))
(setq ent (entget (ssname ss i)))
(setq ends (endsofent ent))
(princ ".")
; (princ "\n")
; (princ (car ends))
; (princ " -- ")
; (princ (cadr ends))
(endsnear (car ends) gaplimit)
(endsnear (cadr ends) gaplimit)
)
)
(defun circle (pt r)
(command "circle" pt r)
(if (= CNT nil)
(setq CNT 1)
(setq CNT (1+ CNT))
)
)
; Finds the entities near a point and marks their ends if they
; are also near the point
(defun endsnear ( pt dist / ent ends)
(if (setq sse (ssat pt dist))
(progn
(setq j (sslength sse))
(while (> j 0)
(setq j (1- j))
(setq ent (entget (ssname sse j)))
(if
(setq ends (endsofent ent))
(progn
(setq d (distance (car ends) pt))
(if (< 0.0 d gaplimit)
(circle pt circlesize)
)
(setq d (distance (cadr ends) pt))
(if (< 0.0 d gaplimit)
(circle pt circlesize)
)
)
)
)
)
)
)
; Main control function
(defun c:GPS ( / ss )
(setvar "cmdecho" 0)
(command "._undo" "be")
(setq #OSMOD (getvar "osmode"))
(setvar "osmode" 0)
(setq #CURLA (getvar "clayer"))
(setq CNT nil)
(if (= gaplimit nil)
(or
(setq gaplimit (getdist "\nSet Gap Limit : "))
(setq gaplimit 1.0)
)
(progn
(setq gaplimit2 gaplimit)
(or
(setq gaplimit (getdist (strcat "\nSet Gap Limit : ")))
(setq gaplimit gaplimit2)
)
)
)
(if (= fluff nil)
(or
(setq fluff (getdist "\nSet Fluff : "))
(setq fluff 0.0001)
)
(progn
(setq fluff2 fluff)
(or
(setq fluff (getdist (strcat "\nSet Fluff : ")))
(setq fluff fluff2)
)
)
)
(if (= circlesize nil)
(or
(setq circlesize (getdist "\nSet Circle Size : "))
(setq circlesize 2.0)
)
(progn
(setq circlesize2 circlesize)
(or
(setq circlesize (getdist (strcat "\nSet Circle Size : ")))
(setq circlesize circlesize2)
)
)
)
(command "._layer" "m" "GAP" "c" "1" "GAP" "")
(princ "\nSelect objects or for all: ")
(or
(and
(setq ss (ssget))
(setq ss (checkss ss))
)
(setq ss (ssget "x"
'((-4 . "")
)
)
)
)
(princ "\nChecking for Gaps - please wait")
(markgaps ss)
(princ "done!")
(if (/= CNT nil)
(princ (strcat "\n" (itoa CNT) " Circles drawn."))
(princ "\nNo Gaps found.")
)
(setvar "clayer" #CURLA)
(setvar "osmode" #OSMOD)
(command "._undo" "e")
(setvar "cmdecho" 1)
(princ)
)
(prompt "\nLOCATE GAPS is loaded... type GAP to start!")
(princ)
(c:gps)

Making selection set of LINES, LWPOLYLINES, ARCS, CIRCLES, SPLINES or ELLIPSES with specific length and angle

13 Thursday Jun 2019

Posted by danglar71 in Utilites

≈ Leave a comment


;;;Making selection set of LINES, LWPOLYLINES, ARCS, CIRCLES, SPLINES or ELLIPSES with specific length and angle
;;---------------=={ 3dwannab_Sel_Layer_Current.lsp }==-----------------;;
;; ;;
;; Selects LINES, LWPOLYLINES, ARCS, CIRCLES, SPLINES ;;
;; or ELLIPSES by exact length ;;
;;----------------------------------------------------------------------;;
;; Author: *Claypool, Jim ;;
;; Edit: 3dwannab
;; Edit: Igal Averbuh 2019 ;;
;;----------------------------------------------------------------------;;
;; Version 1.0 - 11-10-2002 - *Claypool, Jim ;;
;; Version 1.1 - 09-03-2017 - 3dwannab (First Edit) ;;
;; Version 1.11 - 09-03-2017 - 3dwannab (added SPLINE,ELLIPSE)
;; Version 1.12 - 13-06-2019 - Igal Aberbuh (added option for exact length) ;;
;;----------------------------------------------------------------------;;
;; Original: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/delete-lines-shorter-than-specify-length/m-p/909791#M135449
;;----------------------------------------------------------------------;;

(defun c:QS( / ss1 ss2 cnt selcnt ename e len)

(vl-load-com)
(setq ss2 (ssadd))

(setq maxsize (getdist "\nEnter Exact length of LINES, LWPOLYLINES, ARCS, CIRCLES, SPLINES or ELLIPSES: "))
(setq ss1 (ssget "X" '((0 . "LINE,ARC,LWPOLYLINE,CIRCLE,SPLINE,ELLIPSE"))))

(setq cnt 0 selcnt 0)
(if ss1
(progn
(repeat (sslength ss1)
(setq

ename (ssname ss1 cnt)

e (vlax-ename->vla-object ename)
len
(vlax-curve-getdistAtParam e (vlax-curve-getEndParam e))

)
(if
(equal len
maxsize)
(progn

(ssadd ename ss2)

(setq selcnt (1+ selcnt))

)

)
(setq cnt (1+ cnt))
)
(princ (strcat "\nNew Selection " (itoa selcnt) " of " (itoa cnt) " selected LINES, LWPOLYLINES, ARCS, CIRCLES, SPLINES or ELLIPSES")) (princ)
(sssetfirst nil ss2)
)
)
)

;; End of FN ;;

(c:qs)

← 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

Create a free website or 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