Polyline Boundary Creator (closed LWPOLYLINE boundary)


;;; Polyline Boundary Creator (closed LWPOLYLINE boundary)
;;; Created by Marko Ribar, d.i.a. (graduated engineer of architecture)
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/creating-pline-boundary/td-p/8502681

(defun c:bc ( / pea ff f ss sss ch i s stp enp p1 p2 pl sp spp ssp li1 li2 rl )
(setq pea (getvar 'peditaccept))
(while (null ff)
(while (null f)
(if
(or
(prompt "\nSelect by fence open LWPOLYLINES in correct sequence to form closed LWPOLYLINE boundary - when asked for selection, TYPE \"F\"...")
(not (setq ss (ssget "_:L" '((0 . "LWPOLYLINE") (-4 . "")))))
)
(setq f t)
(prompt "\nOK, keep going...")
)
(if (null sss)
(setq sss ss)
(setq sss (acet-ss-union (list sss ss)))
)
)
(initget "Yes No")
(setq ch (getkword "\nENTER TO FINISH SELECTION - Finish selecting or keep going [Yes/No] : "))
(if (null ch)
(setq ch "Yes")
)
(if (= ch "Yes")
(setq ff t)
(setq f nil)
)
)
(repeat (setq i (sslength sss))
(setq s (ssadd))
(ssadd (ssname sss (setq i (1- i))) s)
(if s
(progn
(setq stp (cdr (assoc 10 (entget (ssname s 0)))))
(setq enp (cdr (assoc 10 (reverse (entget (ssname s 0))))))
(setq pl (cons (list stp enp) pl))
(if (= (length pl) 1)
(setq sp s)
(progn
(vl-cmdf "_.COPY" sp "" "_non" '(0.0 0.0 0.0) "_non" '(0.0 0.0 0.0))
(setq spp (entlast))
(vl-cmdf "_.COPY" s "" "_non" '(0.0 0.0 0.0) "_non" '(0.0 0.0 0.0))
(setq ssp (entlast))
(if (inters (caadr pl) (caar pl) (cadadr pl) (cadar pl))
(progn
(setq li1 (entmakex (list '(0 . "LINE") (cons 10 (caadr pl)) (cons 11 (cadar pl)))))
(setq li2 (entmakex (list '(0 . "LINE") (cons 10 (cadadr pl)) (cons 11 (caar pl)))))
)
(progn
(setq li1 (entmakex (list '(0 . "LINE") (cons 10 (caadr pl)) (cons 11 (caar pl)))))
(setq li2 (entmakex (list '(0 . "LINE") (cons 10 (cadadr pl)) (cons 11 (cadar pl)))))
)
)
(setvar 'peditaccept 1)
(vl-cmdf "_.PEDIT" "_M" spp li1 ssp li2 "" "_J")
(while (< 0 (getvar 'cmdactive))
(vl-cmdf "")
)
(setvar 'peditaccept pea)
(vl-cmdf "_.REGION" "_L" "")
(setq rl (cons (entlast) rl))
(if (/= (length rl) 1)
(progn
(vl-cmdf "_.UNION" (car rl) (cadr rl) "")
(setq rl (vl-remove-if '(lambda ( x ) (vlax-erased-p x)) rl))
)
)
(setq sp s)
)
)
)
)
)
(if sp
(progn
(vl-cmdf "_.EXPLODE" (car rl))
(while (< 0 (getvar 'cmdactive))
(vl-cmdf "")
)
(setvar 'peditaccept 1)
(vl-cmdf "_.PEDIT" "_M" (ssget "_P") "" "_J")
(while (< 0 (getvar 'cmdactive))
(vl-cmdf "")
)
(setvar 'peditaccept pea)
(sssetfirst nil (ssget "_L"))
)
)
(princ)
)
(c:bc)

Advertisements

Convert Solids selected by user to Outline Polylines


;;; Convert Solids selected by user to Outline Polylines
;;; Created by tom_brabant
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/lisp-help/m-p/783547/highlight/true#M9205

(defun c:so (/ solid pt1 pt2 pt3 pt4)
(prompt "\nPlease select the solids you want to outline.")
(WHILE (NOT (setq solidss (ssget '((0 . "SOLID")))))
(prompt "\nPlease select the solid you want to outline.")
)
(setq i 0)
(while (< i (sslength solidss))
(setq solid (ssname solidss i) i (1+ i) layer (cdr (assoc 8 (entget solid)))
)
(SETQ pt1 (cdr (assoc 10 (entget solid)))
pt2 (cdr (assoc 11 (entget solid)))
pt3 (cdr (assoc 12 (entget solid)))
pt4 (cdr (assoc 13 (entget solid)))
)
(command "layer" "s" layer "")
(COMMAND "_.PLINE" PT1 PT2 PT4 PT3 "C") (command ".erase" solid "")
);while
);DEFUN

Convert Text to Leader


;;; By RonJon
;;; Found at http://www.cadtutor.net/forum/showthread.php?41822-changing-text-mtext-to-multileaders...
;;; modified by Tom Scaife on Aug.30.2017
;;; The "select objects" request is refering to the existing text you want in the new multileader.
;;; Modified by Tom Scaife on Sep.01.2017 to setup the layer and mleader style
;;; Modified by Igal Averbuh 2019 (added option to change arrow head size and text height as ratio of DIMSCALE)

(command "._MLEADERSTYLE")

;;;====================================================================;
;;; 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:MLD(/ ss data leader-10-list start-pt last-pt one-before-the-last-pt
lyr curlyr)
(setvar "cmdecho" 0)
(setq curlyr (getvar "clayer"))
(command "UNDO" "mark") ;undo mark
(setq ITEMS (ssget "L" '((0 . "MULTILEADER")))) ;select items
(setq i (sslength ITEMS)) ;counter
(while (> i 0) ;while items left
(defun massoc (key EntData / x nlist)
(foreach x EntData
(if (eq key (CAR x))
(setq nlist (cons (cdr x) nlist))
) ;_ end of if
) ;_ end of foreach
(reverse nlist)
) ;_ end of DEFUN
(setq i (1- i)) ;decrement counter
(setq EN (ssname ITEMS i)) ;get name
(setq data (entget EN)) ;entity info
(setq lyr (cdr (assoc 8 data)))
(setq leader-10-list (massoc 10 data))
(setq start-pt (nth 2 leader-10-list)) ;_ 3dr
(setq last-pt (nth 0 leader-10-list)) ;_1st
(setq one-before-the-last-pt (nth 1 leader-10-list)) ;_ 2nd
(command "._explode" EN)
(command "._erase" "L" "")
(command "._erase" "L" "")
(command "._erase" "L" "")
(command "-layer" "Set" lyr "")
(command "._leader" start-pt one-before-the-last-pt last-pt "" "" "None")
(command "-layer" "Set" curlyr "")
); end while
(setvar "cmdecho" 1)
(princ)
) ;_ end of defun

(defun c:t2m (/ newleader pt1 pt2 ss txt x w rjp-getbbwdth)

(setvar "CMLEADERSTYLE" "standard")

(setvar 'DIMSCALE
(cond ((getdist (strcat "\nSpecify Dim Scale : ")))
((getvar 'DIMSCALE))
)
)

(setvar "MLEADERSCALE" (getvar "DIMSCALE"))

(vl-load-com)
(defun rjp-getbbwdth (obj / out ll ur)
(vla-getboundingbox obj 'll 'ur)
(setq out (mapcar 'vlax-safearray->list (list ll ur)))
(distance (car out) (list (caadr out) (cadar out)))
)
(princ "Pick text for new multileader.")
(if (setq ss (ssget '((0 . "*TEXT"))))
(progn (setq txt (apply
'strcat
(mapcar
'cdr
(vl-sort
(mapcar '(lambda (x)
(cons (vlax-get x 'insertionpoint)
(strcat (vlax-get x 'textstring) " ")
)
)
(setq
ss (mapcar
'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
)
(function (lambda (y1 y2) ())
txt (apply 'strcat
(mapcar 'chr (reverse (cdr (reverse (vl-string->list txt)))))
)
)
(mapcar 'vla-delete ss)
)
)
(if (and (setq pt1 (getpoint "\nSpecify leader arrowhead location: "))
(setq pt2 (getpoint pt1 "\nSpecify landing location: "))
)
(progn (command "._MLEADER" pt1 pt2 "")
(setq newleader (vlax-ename->vla-object (entlast)))
(vla-put-textstring newleader txt)
(vla-put-textwidth newleader w)
)
)

(princ)

)
(defun c:t2l (/ )
(c:tds)
(c:t2m)
(c:mld)
)
(c:t2l)

Convert Text to Multi-Leader


;;; By RonJon
;;; Found at http://www.cadtutor.net/forum/showthread.php?41822-changing-text-mtext-to-multileaders...
;;; modified by Tom Scaife on Aug.30.2017
;;; The "select objects" request is refering to the existing text you want in the new multileader.
;;; Modified by Tom Scaife on Sep.01.2017 to setup the layer and mleader style
;;; Modified by Igal Averbuh 2019 (added option to change arrow head size and text height as ratio of DIMSCALE)

(command "._MLEADERSTYLE")

;;;====================================================================;
;;; 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:t2m1 (/ newleader pt1 pt2 ss txt x w rjp-getbbwdth)

(setvar "CMLEADERSTYLE" "standard")

(setvar 'DIMSCALE
(cond ((getdist (strcat "\nSpecify Dim Scale : ")))
((getvar 'DIMSCALE))
)
)

(setvar "MLEADERSCALE" (getvar "DIMSCALE"))
(while
(vl-load-com)
(defun rjp-getbbwdth (obj / out ll ur)
(vla-getboundingbox obj 'll 'ur)
(setq out (mapcar 'vlax-safearray->list (list ll ur)))
(distance (car out) (list (caadr out) (cadar out)))
)
(princ "Pick text for new multileader.")
(if (setq ss (ssget '((0 . "*TEXT"))))
(progn (setq txt (apply
'strcat
(mapcar
'cdr
(vl-sort
(mapcar '(lambda (x)
(cons (vlax-get x 'insertionpoint)
(strcat (vlax-get x 'textstring) " ")
)
)
(setq
ss (mapcar
'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
)
(function (lambda (y1 y2) ())
txt (apply 'strcat
(mapcar 'chr (reverse (cdr (reverse (vl-string->list txt)))))
)
)
(mapcar 'vla-delete ss)
)
)
(if (and (setq pt1 (getpoint "\nSpecify leader arrowhead location: "))
(setq pt2 (getpoint pt1 "\nSpecify landing location: "))
)
(progn (command "._MLEADER" pt1 pt2 "")
(setq newleader (vlax-ename->vla-object (entlast)))
(vla-put-textstring newleader txt)
(vla-put-textwidth newleader w)
)
)

(princ)

)
)

(defun c:t2m (/)
(c:tds)
(c:t2m1)
)
(c:t2m)

Draw “Background” Mask under entities selected by user


;;; Draw "Background" Mask under entities selected by user
;;; Based on routine created by BeekeeCZ and saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-avode-double-selection/td-p/8495611
;;; Combined and Deeply modified by Igal Averbuh 2019
;;; Used Lee Mak Burst Upgraded routine http://www.lee-mac.com/upgradedburst.html
;;; Finaly modified by BeekeeCZ https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-avode-double-selection/td-p/8495611/page/2

(vl-load-com)

; Required ExpressTools

(defun c:BG ( / *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))

(if (and (setq sel (ssget "_:L" '((0 . "*TEXT,*POLYLINE,*LEADER,DIMENSION,INSERT,SPLINE,LINE,ARC,CIRCLE"))))
(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* '(1 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"))))
(command "_.ERASE" sst ""))

(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" 1 ""))

(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" 42 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" 42 "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)
)

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

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

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

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


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

Select similar within viewport (for current viewable screen)


;; Select similar within viewport (for current viewable screen)
;; Modified by dbhunia
;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/select-similar-for-current-window-view/td-p/8480689

(defun c:SSV (/ filter ss1 ss2 ss3 add i e CurSet ScrPts)
;; Select Similar within Window
;; Uses core SelectSimilar command
;; Alan J. Thompson, 2013.07.30
(setvar 'cmdecho 0)
(setq filter (if (eq (getvar 'CVPORT) 1)
(list (cons 410 (getvar 'CTAB)))
'((410 . "Model"))
)
)
(princ "\nSelect objects to select similar: ")
(if (and (setq ss1 (ssget filter)
ScrPts (GetScreenCoords)
ss2 (ssget "C" (car ScrPts) (cadr ScrPts))
)
)
(progn (command "_.selectsimilar" ss1 "")
(if (setq ss3 (ssget "_I" filter))
(progn (sssetfirst nil nil)
(setq add (ssadd))
(repeat (setq i (sslength ss3))
(if (ssmemb (setq e (ssname ss3 (setq i (1- i)))) ss2)
(setq add (ssadd e add))
)
)
(sssetfirst nil add)
)
)
)
)
(setvar 'cmdecho 1)
(princ)
)
(defun GetScreenCoords ( / ViwCen ViwDim ViwSiz VptMin VptMax)
(setq ViwSiz (/ (getvar "VIEWSIZE") 2.0)
ViwCen (getvar "VIEWCTR")
ViwDim (list (* ViwSiz (apply '/ (getvar "SCREENSIZE"))) ViwSiz)
VptMin (mapcar '- ViwCen ViwDim)
VptMax (mapcar '+ ViwCen ViwDim)
)
(list VptMin VptMax)
)
(c:ssv)

Select Similar within Window


;; Select Similar within Window
;; Uses core SelectSimilar command
;; Alan J. Thompson, 2013.07.30
;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/select-similar-for-current-window-view/td-p/8480689

(defun c:SSW (/ filter ss1 ss2 ss3 add i e)

(setq filter (if (eq (getvar 'CVPORT) 1)
(list (cons 410 (getvar 'CTAB)))
'((410 . "Model"))
)
)
(princ "\nSelect objects to select similar: ")
(if (and (setq ss1 (ssget filter))
(progn (princ "\nSelect area to select similar object(s) within: ")
(setq ss2 (ssget filter))
)
)
(progn (command "_.selectsimilar" ss1 "")
(if (setq ss3 (ssget "_I" filter))
(progn (sssetfirst nil nil)
(setq add (ssadd))
(repeat (setq i (sslength ss3))
(if (ssmemb (setq e (ssname ss3 (setq i (1- i)))) ss2)
(setq add (ssadd e add))
)
)
(sssetfirst nil add)
)
)
)
)
(princ)
)
(c:ssw)

Dimension Along Curve (added option to set arrow head and dimension text size)


;; Dimension Along Curve
;; Created by Lee Mac 2012
;; Saved from: https://forums.autodesk.com/t5/civil-3d-forum/dimension-along-polyline/td-p/6259008
;; Slightly modified by Igal Averbuh 2018 (added option to set arrow head and dimension text size)

(defun c:dac ( / _line _arrow a b cm el en p q pt )

(setvar 'DIMASZ
(cond ((getdist (strcat "\nSpecify Arrow Head Size : ")))
((getvar 'DIMASZ))
)
)

(setvar 'dimtxt
(cond ((getdist (strcat "\nSpecify Dimension Text Size : ")))
((getvar 'dimtxt))
)
)

(defun _line ( a b )
(entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b)))
)

(defun _arrow ( a b )
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 2)
'(70 . 0)
(cons 10 a)
'(40 . 0.0)
(cons 41 (/ (distance a b) 3.0))
(cons 10 b)
)
)
)

(while
(progn (setvar 'errno 0) (setq en (car (entsel)))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (eq 'ename (type en))
(if (not (wcmatch (cdr (assoc 0 (entget en))) "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE,SPLINE"))
(princ "\nInvalid Object Selected.")
)
)
)
)
)
(if
(and en
(setq pt
(getpoint "\nSpecify Dimension Offset: "
(trans
(vlax-curve-getpointatparam en
(/ (+ (vlax-curve-getendparam en) (vlax-curve-getstartparam en)) 2.0)
)
0 1
)
)
)
)
(progn
(setq el (entlast)
cm (getvar 'cmdecho)
)
(setvar 'cmdecho 0)
(command "_.offset" "_T" en "_non" pt "")
(setvar 'cmdecho cm)
(if (equal el (setq el (entlast)))
(princ "\nUnable to Create Dimension Line.")
(progn
(setq a (vlax-curve-getstartpoint en)
b (vlax-curve-getstartpoint el)
)
(_line
(polar a (angle a b) (/ (distance a b) 6.0))
(polar b (angle a b) (/ (distance a b) 6.0))
)
(setq a (vlax-curve-getendpoint en)
b (vlax-curve-getendpoint el)
)
(_line
(polar a (angle a b) (/ (distance a b) 6.0))
(polar b (angle a b) (/ (distance a b) 6.0))
)
(_arrow
(vlax-curve-getstartpoint el)
(polar (vlax-curve-getstartpoint el)
(angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv el (vlax-curve-getstartparam el)))
(getvar 'dimasz)
)
)
(_arrow
(vlax-curve-getendpoint el)
(polar (vlax-curve-getendpoint el)
(+ pi (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv el (vlax-curve-getendparam el))))
(getvar 'dimasz)
)
)
(setq a (vlax-curve-getpointatdist el (/ (vlax-curve-getdistatparam el (vlax-curve-getendparam el)) 2.0))
b (angle '(0.0 0.0) (vlax-curve-getfirstderiv el (vlax-curve-getparamatpoint el a)))
p (polar a (+ b (/ pi 2.0)) (getvar 'dimtxt))
q (polar a (- b (/ pi 2.0)) (getvar 'dimtxt))
)
(if (< (distance p (vlax-curve-getclosestpointto en p))
(distance q (vlax-curve-getclosestpointto en q))
)
(setq p q)
)
(entmake
(list
'(000 . "TEXT")
(cons 10 p)
(cons 11 p)
(cons 40 (getvar 'dimtxt))
(cons 01 (rtos (vlax-curve-getdistatparam en (vlax-curve-getendparam en))))
(cons 50 (LM:readable b))
'(072 . 1)
'(073 . 2)
)
)
)
)
)
)
(princ)
)

;; Readable - Lee Mac
;; Returns an angle corrected for text readability.

(defun LM:readable ( a )
( (lambda ( a )
(if (< a 0.0)
(LM:readable a)
(if (and (< (* pi 0.5) a) (<= a (* pi 1.5)))
(LM:readable (+ a pi))
a
)
)
)
(rem (+ a pi pi) (+ pi pi))
)
)

(vl-load-com) (princ)
(c:dac)

Adjust Lineype Scale by relative ratio of 1


;|
AdjLTSPct.lsp [command name = CLS]
To Adjust Lineype Scale by relative ratio of 1.
Concept from c:lsr command, DEC 2009 by 40skb,
Rewritten and expanded by Kent Cooper, Jan 2017:
Multiple-object selection
Remember prior adjustment percentage and offer as default
|;
;; Modified by Igal Averbuh 2018 (changed percentage adjustment to relative ratio of 1)

(defun C:cls (/ ss mult n ent)
(if (setq ss (ssget "_:L"))
(progn
(initget (if *alspct 6 7)); no Enter on first use, no 0, no negative
(setq
*alspct
(cond
( (getreal
(strcat
"\n\nRelative Linetype Scale as ratio of 1 Value greater than 1 will increase the scale:"

); strcat
); getreal
); User-input condition
(*alspct); on Enter [if allowed by presence of]: prior value
); cond & *alspct
mult (/ *alspct 1)
); setq
(repeat (setq n (sslength ss))
(setq ent (ssname ss (setq n (1- n))))
(command
"_.chprop" ent ""
"_ltScale" (* (cond ((cdr (assoc 48 (entget ent)))) (1)) mult)
""
); command
); repeat
); progn
); if
); defun

(vl-load-com)
(c:cls)