Filter close polylines by internal area range


;;; Filter close polylines by internal area range
;;; Author unknown

(defun c:fba ( / *Error* CNT ENT AREA MINAREA MAXAREA ss StartPoint EndPoint)
(vl-load-com)
(command "cmdecho" 0)
(defun *Error* (Msg)
(cond
((or (not Msg)
(member Msg '("console break"
"Function cancelled"
"quit / exit abort"
)
) ;close member
) ;close or
) ;close condition, no message to display
((princ (strcat "\nError: " Msg))) ;else display message
) ;close cond
(princ)
) ;close defun *Error*

(setq MINAREA (getdist "\nEnter minimum area value: "))
(setq MAXAREA (getdist "\nEnter maximum area value: "))

(if (ssget "I")
(setq SS (ssget "I" '((0 . "LWPOLYLINE"))))
(setq SS (ssget '((0 . "LWPOLYLINE"))))
) ;end if

(setq CNT 0)
(repeat (sslength SS)

(setq ENT (ssname SS CNT)
AREA (vla-get-area (vlax-ename->vla-object ENT))
StartPoint (vlax-curve-getStartPoint (vlax-ename->vla-object ENT))
EndPoint (vlax-curve-getEndPoint (vlax-ename->vla-object ENT))
) ;end setq

(if (or (and (= MAXAREA AREA) (equal StartPoint EndPoint))
(equal MINAREA AREA 0.00001)
(equal MAXAREA AREA 0.00001)
) ;end or
(setq CNT (1+ CNT))
(ssdel ENT SS)
) ;end if
) ;end repeat
(command "cmdecho" 1)
(if (> (sslength SS) 0)
(progn
(princ (strcat "Number of objects selected = "(itoa (sslength SS))))
(sssetfirst nil SS)
) ;progn
(princ "No objects met the criteria ") ;else
) ;end if
(*Error* nil)
(princ)
) ;end defun

Filter lines and polylines by length range or by fixed length


;;; Filter lines and polylines by length range or by fixed length
;;; Author unknown

(defun c:FBL ( / *Error* cnt ent fixlen len stpt enpt maxlen minlen mode ss OPT)
(vl-load-com)
(defun *Error* (Msg)
(cond
((or (not Msg)
(member Msg '("console break"
"Function cancelled"
"quit / exit abort"
)
) ;close member
) ;close or
) ;close condition, no message to display
((princ (strcat "\nError: " Msg))) ;else display message
) ;close cond
(princ)
) ;close defun *Error*

(initget 1 "L P B")
(setq OPT (getkword "\nWant to Select [Line/Polyline/Both]: "))

(initget 1 "R F ")
(setq MODE
(getkword "\nSelect lines within (R)ange or (F)ixed length : "))
;(if (or (= MODE "") (= MODE "F"))
;(setq MODE "F")
;) ;end if

(if (= MODE "F")
(setq FIXLEN (getdist "\nEnter fixed line length: "))
(progn
(setq MINLEN (getdist "\nEnter minimum length: "))
(setq MAXLEN (getdist "\nEnter maximum length: "))
) ;end progn else
) ;end if

(if (ssget "I")
(progn
(cond ((= OPT "L")
(setq SS (ssget "I" '((0 . "LINE"))))
) ;end cond L

((= OPT "P")
(setq SS (ssget "I" '((0 . "*POLYLINE"))))
) ;end cond P
((= OPT "B")
(setq SS (ssget "I" '((0 . "LINE,*POLYLINE"))))
) ;end cond B
) ;end conditions
)
(progn
(cond ((= OPT "L")
(setq SS (ssget '((0 . "LINE"))))
) ;end cond L

((= OPT "P")
(setq SS (ssget '((0 . "*POLYLINE"))))
) ;end cond P
((= OPT "B")
(setq SS (ssget '((0 . "LINE,*POLYLINE"))))
) ;end cond B
) ;end conditions
)
) ;end if
(setq CNT 0)
(repeat (sslength SS)

(setq ENT (ssname SS CNT)
;STPT (cdr (assoc 10 (entget ENT)))
;ENPT (cdr (assoc 11 (entget ENT)))
LEN (vla-get-length (vlax-ename->vla-object ENT))
) ;end setq

(cond ((= MODE "F")
(if (equal FIXLEN LEN 0.00001)
(setq CNT (1+ CNT)) ;then next
(ssdel ENT SS) ;else delete
) ;end if
) ;end cond F

((= MODE "R")
(if (or (and (= MAXLEN LEN))
(equal MINLEN LEN 0.00001)
(equal MAXLEN LEN 0.00001)
) ;end or
(setq CNT (1+ CNT))
(ssdel ENT SS)
) ;end if
) ;end cond R
) ;end conditions
) ;end repeat

(if (> (sslength SS) 0)
(progn
(princ (strcat "Number of objects selected = "(itoa (sslength SS))))
(sssetfirst nil SS)
) ;progn
(princ "No objects met the criteria ") ;else
) ;end if
(*Error* nil)
(princ)
) ;end defun

Create Viewport in Paper Space from specified 2D orthogonal view in Model Space and rotate created view parallel to rotated MS object with selecting rotation angle by 2 points on object within viewport.


;;; Create Viewport in Paper Space from specified 2D orthogonal view in Model Space
;;; and rotate created view parallel to rotated MS object with selecting rotation angle by 2 points on MS object.
;;; Created by Igal Averbuh 2019
;;; Based on modified version of Clark Johnson and SWARAJ BARAL routines

(defun c:rv (/ sset DPL DPLS vprt a1 a2)

;;; Rotate View in paperspace
;;; Written By Clark Johnson - Toromont Energy Systems, Inc.
;;; Concept from Cadalyst Tips & Tools Weekly - Sept. 15, 2008 - http://www.cadalyst.com
;;; by SWARAJ BARAL
;;;
;;; Modified by Igal Averbuh 2019 (added option to set the view angle specified by two points)

(vl-load-com)
(setvar "cmdecho" 0)
(command "pspace");;move to paperspace
(terpri)
(setq sset(ssget "L" '((0 . "viewport"))));;Select viewport
;;;
(setq DPL (vlax-ename->vla-object (ssname sset 0)));;Get viewport name
(setq DPLS (vlax-get-property DPL "DisplayLocked"));;Get Locked Status for Viewport
(vla-put-DisplayLocked DPL :vlax-true);; LOCK Viewport
;;;
(setq vprt(cdr(assoc 69 (entget(ssname sset 0)))))
(command "._mspace")
(princ "\nSelect view rotation angle by 2 points on screen")

(setq P1 (getpoint "\nEnter First Point :"))
(setq P2 (getpoint P1 "\nSecond Point :"))
(vla-put-DisplayLocked DPL :vlax-false);; UNLOCK Viewport

;(setq a1 (getangle "\nEnter or Select rotation angle..."));;Get Rotation Angle
;(setq a2 (* a1 57.29578))

(command "mspace");;move to modelspace
(command "cvport" vprt);;Get selected viewport

(command "DVIEW" "" "TW" (/ (* -180 (angle P1 P2)) pi) "")

(command "pspace");;Return to paperspace
;;;
(vla-put-DisplayLocked DPL :vlax-true)
;(vla-put-DisplayLocked DPL DPLS);;; Restore Locked Status for Viewport
;;;
(setvar "cmdecho" 1)
(princ)
)

(defun c:ivp (/ vpl vplyes l0 ln layers cp cl cs ofs vpc1 vpc2 vpxd vpyd vpc svpc ssvp ssvp1 sf lpno vpno ssnum vpent nvpc1 nvpc2 nvpc1x nvpc1y nvpc2x nvpc2y)

(setvar "cmdecho" 0) ; Turn off command line echoing
(setvar "tilemode" 0)
(setq cp (getvar "ctab")) ; Store current tab name
(setq cl (getvar "clayer")) ; Store current layer name
(setq cs (getvar "osmode")) ; Store current osnap mode
(setq vpl "Viewport") ; ==>> Assume using Viewport layer for viewport frames, change code value here if needed <> Set viewport border offset from actual detail, change code value here if needed <<==
(setvar "osmode" 16416) ; Turn osnap off
(if (/= cp "Model") ; Must be started from a layout tab to establish destination, quit quietly if on Model tab
(progn
(princ "\n") ; Clean up command line
(setq vplyes 0) ; Assume viewport doesn't exist
(setq l0 (tblnext "LAYER" 1)) ; Get past 0 layer in layer list
(while (setq layers (tblnext "LAYER")) ; Loop through layer list collection
(setq ln (cdr (assoc 2 layers))) ; Extract layer name from list
(if (= (strcase ln) (strcase vpl)) (setq vplyes 1)) ; Check if viewport layer exists
)
(if (= vplyes 0) (command "layer" "NEW" vpl "COLOR" "1" vpl "")) ; Make viewport layer and assign color to red if doesn't exist
(setvar "clayer" vpl) ; Change to viewport layer
(command "layer" "ON" (strcat "0," vpl) "UNLOCK" (strcat "0," vpl) "") ; Turn on and unlock viewport and 0 layer
(command "zoom" "e") ; View entire layout tab
(setvar "ctab" "Model") ; Activate Model tab
; (command "zoom" "e") ; View entire Model Space area
(setq vpc1 (getpoint "\nSpecify first corner of model space window area: ")) ; Just pick rough area including all relavent details, will fine-tune border area later in Paper Space
(if vpc1 ; Quietly quit if no point specified
(progn
(setq vpc2 (getcorner vpc1 "\nSpecify opposite corner of model space window area: ")) ; Window rectangle can be designated in any direction
(if vpc2 ; Quietly quit if no point specified
(progn
(princ "\n") ; Clean up command line
(setvar "ctab" cp) ; Return to layout tab program was started from
(command "pspace") ; Switch to Paper Space of layout tab
(setq svpc (getpoint "\nSpecify destination of paper space viewport center: ")) ; Can't change layout tabs manually here
(if svpc ; Quietly quit if no point specified
(progn
(setq sf (getreal "\nViewport zoom scale factor : ")) ; Default to full-scale if no value is inputted
(if (= sf nil) (setq sf 1.0) (setq sf (abs sf))) ; Make sure scale factor is positive number
(setq vpxd (* sf (abs (- (car vpc2) (car vpc1))))) ; Determine horizontal length of selected window
(setq vpyd (* sf (abs (- (cadr vpc2) (cadr vpc1))))) ; Determine vertical height of selected window
(setq vpc (list (/ (+ (car vpc1) (car vpc2)) 2.0) (/ (+ (cadr vpc1) (cadr vpc2)) 2.0) 0.0)) ; Determine center point of selected model window
(command "mview" (list (- (car svpc) (/ vpxd 2.0)) (- (cadr svpc) (/ vpyd 2.0))) (strcat "@" (rtos vpxd) "," (rtos vpyd))) ; Create Paper Space viewport
(setq ssvp (ssget "L")) ; Start selection set with last viewport frame
(setq ssvp1 (ssget "L")) ; Another copy of viewport frame selection set
(command "mspace") ; Open viewport window to Model Space
(command "ucsicon" "ON") ; Turn on UCS icon for viewport
(command "ucs" "WORLD") ; Reset UCS to WCS
(command "zoom" "C" vpc (rtos vpyd)) ; Center view of viewport window using determined point
(command "zoom" "SCALE" (strcat (rtos sf) "XP")) ; Set zoom scale of viewport window
(command "vports" "LOCK" "ON" ssvp "") ; Lock scale and position of model in viewport
(command "pspace") ; Close viewport window
(command "zoom" (list (- (car svpc) (/ vpxd 2.0)) (- (cadr svpc) (/ vpyd 2.0))) (strcat "@" (rtos vpxd) "," (rtos vpyd))) ; Zoom in on just created viewport extremes
(command "zoom" "0.95X") ; Back zoom off slightly to see edges clearly
(setq lpno 2) ; Loop counter for making separate viewports
(setq vpno 1) ; Create single viewport
(if (>= vpno 2) ; Proceed to copy current viewport if 2 or more separate viewports desired
(progn
(while (<= lpno vpno) ; Check if viewport loop counter less than number of viewports desired
(command "copy" ssvp "" "0,0" "@0,0") ; Make copy of new viewport laying exactly on top of first viewport
(setq lpno (1+ lpno)) ; Increment viewport loop counter
(ssadd (entlast) ssvp1) ; Add viewport copy to selection set
)
)
)
(setq ssnum 0) ; Loop counter for fine-tuning separate viewports
(while (= vpno 2) ; Check for multiple viewports
(setq clt (strcat " #" (rtos (+ ssnum 1) 2 0))) ; Make command prompt string if using multiple viewports
(setq clt "") ; Make command prompt string if using single viewport
)
(initget 128) ; Enable string responses from point prompt
(setvar "osmode" 32)
(setq nvpc1 (getpoint (strcat "\nSpecify first corner of viewport" clt " window area or [Center point of circle]: "))) ; Pick actual part corner, program will apply offset
(if nvpc1 ; Will repeat asking for first corner if none specified
(progn
(if (= 'STR (type nvpc1)) ; Check if string was inputted instead of corner point
(progn
(if (= "C" (strcase (substr nvpc1 1 1))) ; Check if asking for circular viewport area
(progn
(setq nvpc1 (getpoint (strcat "\nSpecify center of viewport" clt " window area: "))) ; Pick center of separate circular viewport window
(if nvpc1 ; Will return to asking for first corner if center not specified
(progn
(setvar "osmode" 0) ; Turn osnap off
(princ (strcat "\nSpecify radius of viewport" clt " window area: ")) ; Make command prompt for circle viewport
(command "circle" nvpc1 pause) ; Make circle to clip existing viewport
(setvar "osmode" 2559) ; Turn osnap on
(setq ssvp (ssget "L")) ; Select last circle
(command "vpclip" vpent ssvp) ; Clip existing viewport to circle
(setq ssnum (1+ ssnum)) ; Increment fine-tuned viewport loop counter
)
)
)
)
)
(progn
(setq nvpc2 (getcorner nvpc1 (strcat "\nSpecify opposite corner of viewport" clt " window area: "))) ; Window rectangle can be designated in any direction, pick actual part corner, program will apply offset
(if nvpc2 ; Will repeat asking for first corner if none specified
(progn
(setq nvpc1x (car nvpc1)) ; Find X portion of first corner
(setq nvpc1y (cadr nvpc1)) ; Find Y portion of first corner
(setq nvpc2x (car nvpc2)) ; Find X portion of second corner
(setq nvpc2y (cadr nvpc2)) ; Find Y portion of second corner
(if (> nvpc2x nvpc1x) ; Determine horizontal direction of viewport window rectangle
(progn
(setq nvpc2x (+ nvpc2x ofs)) ; Add horizontal offset to right of specified left-to-right window rectangle
(setq nvpc1x (- nvpc1x ofs)) ; Add horizontal offset to left of specified left-to-right window rectangle
)
(progn
(setq nvpc2x (- nvpc2x ofs)) ; Add horizontal offset to left of specified right-to-left window rectangle
(setq nvpc1x (+ nvpc1x ofs)) ; Add horizontal offset to right of specified right-to-left window rectangle
)
)
(if (> nvpc2y nvpc1y) ; Determine vertical direction of viewport window rectangle
(progn
(setq nvpc2y (+ nvpc2y ofs)) ; Add vertical offset to top of specified lower-to-upper window rectangle
(setq nvpc1y (- nvpc1y ofs)) ; Add vertical offset to bottom of specified lower-to-upper window rectangle
)
(progn
(setq nvpc2y (- nvpc2y ofs)) ; Add vertical offset to bottom of specified upper-to-lower window rectangle
(setq nvpc1y (+ nvpc1y ofs)) ; Add vertical offset to top of specified upper-to-lower window rectangle
)
)
(setvar "osmode" 0) ; Turn osnap off
(command "rectang" (list nvpc1x nvpc1y) (list nvpc2x nvpc2y)) ; Make rectangle with offset to clip existing viewport
(setvar "osmode" 2559) ; Turn osnap on
(setq ssvp (ssget "L")) ; Select last rectange
(command "vpclip" vpent ssvp) ; Clip existing viewport to rectangle
(command "vpclip" ssvp "d" ) ; Convert Polygonal Vport to Rectangular

(setq ssnum (1+ ssnum)) ; Increment fine-tuned viewport loop counter
)
)
)
)
)
)
)
)
)
)
)
)
)

(c:rv) ;Rotate View in current viewport

)
(princ "\nThis command must be started from a layout sheet!") ; Need to start on a layout tab so program knows where to create the new viewports
)
(setvar "ctab" cp) ; Reset to stored tab name
(setvar "clayer" cl) ; Reset to stored layer name
(setvar "osmode" cs) ; Reset to stored osnap mode
(setvar "cmdecho" 1) ; Turn on command line echoing
(princ) ; Clean up and exit
)

Rotate View in paperspace (view rotation angle by 2 points on screen)


;;; Rotate View in paperspace
;;; Written By Clark Johnson - Toromont Energy Systems, Inc.
;;; Concept from Cadalyst Tips & Tools Weekly - Sept. 15, 2008 - http://www.cadalyst.com
;;; by SWARAJ BARAL
;;;
;;; Modified by Igal Averbuh 2019 (added option to set the view angle specified by two points)

(defun c:rv (/ sset DPL DPLS vprt a1 a2)
(vl-load-com)
(setvar "cmdecho" 0)
(command "pspace");;move to paperspace
(terpri)
(princ "\nSelect Viewport to rotate...")
(setq sset(ssget ":s" '((0 . "viewport"))));;Select viewport
;;;
(setq DPL (vlax-ename->vla-object (ssname sset 0)));;Get viewport name
(setq DPLS (vlax-get-property DPL "DisplayLocked"));;Get Locked Status for Viewport
(vla-put-DisplayLocked DPL :vlax-true);; LOCK Viewport
;;;
(setq vprt(cdr(assoc 69 (entget(ssname sset 0)))))
(command "._mspace")
(princ "\Select view rotation angle by 2 points on screen")

(setq P1 (getpoint "\nEnter First Point :"))
(setq P2 (getpoint P1 "\nSecond Point :"))
(vla-put-DisplayLocked DPL :vlax-false);; UNLOCK Viewport

;(setq a1 (getangle "\nEnter or Select rotation angle..."));;Get Rotation Angle
;(setq a2 (* a1 57.29578))

(command "mspace");;move to modelspace
(command "cvport" vprt);;Get selected viewport

(command "DVIEW" "" "TW" (/ (* -180 (angle P1 P2)) pi) "")

(command "pspace");;Return to paperspace
;;;
(vla-put-DisplayLocked DPL :vlax-true)
;(vla-put-DisplayLocked DPL DPLS);;; Restore Locked Status for Viewport
;;;
(setvar "cmdecho" 1)
(princ)
)

Rotates tables around their insertion points


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

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

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

Count strings within viewport selected by user with table output


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

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

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

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

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

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

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

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

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

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

;;--------------------=={ Text Count }==----------------------;;
;; ;;
;; Counts the number of occurrences of each string in a ;;
;; selection and produces a report in an ACAD Table object ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - http://www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Version 1.0 - 07.11.2010 ;;
;; First Release. ;;
;;------------------------------------------------------------;;
;; Version 1.1 - 05.08.2011 ;;
;; Added Dimensions Override Text & MLeaders ;;
;; Updated 'AddTable' to account for Annotative Text Styles. ;;
;;------------------------------------------------------------;;

(defun c:tc
( /

*error*
_StartUndo
_EndUndo
_Assoc++
_SumAttributes
_GetTextString
_ApplyFooToSelSet

acdoc
acspc
alist
data
pt

)

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

(defun *error* ( msg )
(if acdoc (_EndUndo acdoc))
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\n** Error: " msg " **"))
)
(princ)
)

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

(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)

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

(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)

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

(defun _Assoc++ ( key alist )
(
(lambda ( pair )
(if pair
(subst (list key (1+ (cadr pair))) pair alist)
(cons (list key 1) alist)
)
)
(assoc key alist)
)
)

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

(defun _SumAttributes ( entity alist )
(while
(not
(eq "SEQEND"
(cdr
(assoc 0
(entget
(setq entity (entnext entity))
)
)
)
)
)
(setq alist (_Assoc++ (_GetTextString entity) alist))
)
)

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

(defun _GetTextString ( entity )
(
(lambda ( string )
(mapcar
(function
(lambda ( pair )
(if (member (car pair) '(1 3))
(setq string (strcat string (cdr pair)))
)
)
)
(entget entity)
)
string
)
""
)
)

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

(defun _ApplyFooToSelSet ( foo ss / i )
(if ss (repeat (setq i (sslength ss)) (foo (ssname ss (setq i (1- i))))))
)

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

(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace))
)
(cond
( (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'CLAYER))))))
(princ "\nCurrent Layer Locked.")
)
( (not (vlax-method-applicable-p acspc 'AddTable))
(princ "\nTable Object not Available in this version.")
)
( (and
(setq data
(_ApplyFooToSelSet
(lambda ( entity / typ )
(setq alist
(cond
( (eq "INSERT" (setq typ (cdr (assoc 0 (entget entity)))))
(_SumAttributes entity alist)
)
( (eq "MULTILEADER" typ)
(_Assoc++ (cdr (assoc 304 (entget entity))) alist)
)
( (wcmatch typ "*DIMENSION")
(_Assoc++ (cdr (assoc 1 (entget entity))) alist)
)
( (_Assoc++ (_GetTextString entity) alist) )
)
)
)
(ssget "P"
'(
(-4 . "<OR")
(0 . "TEXT,MTEXT,MULTILEADER")
(-4 . "")
(-4 . "")
(-4 . "OR>")
)
)
)
)
(setq pt (getpoint "\nSpecify Point for Table: "))
)
(_StartUndo acdoc)
(LM:AddTable acspc (trans pt 1 0) "String Count"
(cons (list "String" "Instances")
(vl-sort
(mapcar
(function
(lambda ( x ) (list (car x) (itoa (cadr x))))
)
data
)
(function (lambda ( a b ) ( (setq n (1- n)) -1)
(if (and
(setq ss1 (ssget WC (mapcar 'cdr (vl-remove-if-not '(lambda (item) (= (car item) 10)) (entget (ssname pSS n))))))
(setq m (sslength ss1)) ;number of objects inside of polyline
)
(while (> (setq m (1- m)) -1)
(setq en (ssname ss1 m)) ;en = list of entity names inside of polyline
(ssadd en ss)

)
)

(setq ss1 nil)
(gc)
)
)
(if (> (sslength ss) 1)
(sssetfirst nil ss)
)
)

;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

(defun c:vsc()
(command "_.-LAYER" "_T" "0-STRING-COUNTING" "_U" "0-STRING-COUNTING" "_M" "0-STRING-COUNTING" "_C" 1 "0-STRING-COUNTING" "")
(princ "\n Select ViewPort for STRING Counting...")
(c:vp-outline)
(c:sip)
(c:tc)
(setvar "osmode" 0)

(command "._chspace" "L" "" "")
(c:rot)
(c:sac)
(setvar "osmode" 167)
)
;(c:vsc)

Equal Divide distance between 2 points by XLINES


;;; Equal Divide distance between 2 points by XLINES
;;; Modified by Igal Averbuh 2019

(defun c:XXE ( / p1 p2 x dnum v n num xd k p pl )
(while (setq p1 (if (null p1) (getpoint "\nPick or specify first point : ") p2))
(setq p2 (getpoint p1 "\nPick or specify second point - ENTER TO FINISH : "))
(if (and p1 p2)
(progn
(if (null x)
(setq x (/ (distance p1 p2) 4200))
)
(if (null dnum)
(setq dnum (fix (1+ x)))
(setq dnum (fix (1+ (/ (distance p1 p2) xd))))
)
(setq v (mapcar '- p2 p1))
(setq n (polar '(0.0 0.0) (+ (angle '(0.0 0.0) v) (* 0.5 pi)) 1.0))
(initget 6)
(setq num (getint (strcat "\nSpecify number of division XLINES between two picked points: ")))
(setq num (+ num 1))
(if (null num)
(setq num dnum)
)
(setq xd (/ (distance p1 p2) num))
(setq k 1)
(repeat num
(setq p (polar p1 (angle p1 p2) (* k xd)))
(setq k (1+ k))
(setq pl (cons p pl))
)
(setq pl (reverse pl))
(foreach p pl
(entmake
(list
'(0 . "XLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbXline")
(cons 10 p)
(cons 11 n)
)
)
)
(setq pl nil)
)
)
(command "erase" "L" "")
)
(princ)
(command "undo" "")
)
(c:XXE)

Count blocks within viewport selected by user with table output


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Draw “Background” Mask under entities selected by user (modified version)


;;; 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
;;; Modified by BeekeeCZ https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/how-to-avode-double-selection/td-p/8495611/page/2
;;; Modified by Igal Averbuh 2019 (added option to choose background color and specify background width by 2 points on screen)

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

(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,*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* '(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" col "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 ;;
;;----------------------------------------------------------------------;;

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)