Author Topic: Erase Outside Title Block  (Read 106 times)

0 Members and 1 Guest are viewing this topic.

cmwade77

  • Swamp Rat
  • Posts: 1271
Erase Outside Title Block
« on: July 21, 2021, 06:09:21 PM »
I have code that works in AutoCAD, but because there is some ActiveX, it does not work in AcCoreConsole. Basically, this looks for a title block and erases anything outside of it. Can anyone help me with removing ActiveX (the VLAX- functions) and make it pure LISP please? That way it will work in AcCoreConsole.

Code: [Select]
;Code adapted from LeeMac's code at: http://www.theswamp.org/index.php?topic=43352.msg507568#msg507568
(defun c:EraseOutsideTitleBlock (/ SS BOX SS_ALL SS_KEEP LLP URP ENT idx flg tab)
  ;; Block Name  -  Lee Mac
  ;; Returns the true (effective) name of a supplied block reference
                       
  (defun LM:blockname ( obj )
      (if (vlax-property-available-p obj 'effectivename)
          (defun LM:blockname ( obj ) (vla-get-effectivename obj))
          (defun LM:blockname ( obj ) (vla-get-name obj))
      )
      (LM:blockname obj)
  )
 
  ;; Selection Set Bounding Box  -  Lee Mac
  ;; Returns a list of the lower-left and upper-right WCS coordinates of a
  ;; rectangular frame bounding all objects in a supplied selection set.
  ;; sel - [sel] Selection set for which to return bounding box

  (defun LM:ssboundingbox ( sel / idx llp ls1 ls2 obj urp )
      (repeat (setq idx (sslength sel))
          (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx)))))
          (if (and (vlax-method-applicable-p obj 'getboundingbox)
                  (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'llp 'urp))))
              )
              (setq ls1 (mapcar 'min (vlax-safearray->list llp) (cond (ls1) ((vlax-safearray->list llp))))
                    ls2 (mapcar 'max (vlax-safearray->list urp) (cond (ls2) ((vlax-safearray->list urp))))
              )
          )
      )
      (if (and ls1 ls2) (list ls1 ls2))
  )
  (setq tab (getvar "ctab"))
  (if (setq SS (ssget "_X" (list '(0 . "INSERT") '(8 . "$TB") (cons 410 tab))))
    (progn
      (setq BOX (LM:ssboundingbox SS)
            LLP (car BOX)
            URP (cadr BOX)
            SS_ALL (ssget "_X" (list (cons 410 tab)))
            SS_KEEP (ssget "_W" (mapcar '- llp '(1e-2 1e-2)) (mapcar '+ urp '(1e-2 1e-2)) (list (cons 410 tab)))
      )
     
      (repeat (setq idx (sslength SS_all))
        (if
            (not
                (or (ssmemb (setq ent (ssname SS_all (setq idx (1- idx)))) SS_KEEP)
                    (or (and (= "INSERT" (cdr (assoc 0 (entget ent))))
                          (wcmatch (strcase (LM:blockname (vlax-ename->vla-object ent))) "PLOT STAMP*")
                        )
                        (= "$$tbinfo" (cdr (assoc 8 (entget ent))))
                        (= "$tbinfo" (cdr (assoc 8 (entget ent))))
                    )
                )
            )
            (progn
                (entdel ent)
                (or flg (setq flg (princ "\nObject(s) found outside the title block and will now be deleted.")))
            )
        )
      )   
    )
  )
)

BIGAL

  • Swamp Rat
  • Posts: 769
  • 30 + years of using Autocad
Re: Erase Outside Title Block
« Reply #1 on: July 21, 2021, 09:33:37 PM »
The quick and dirty if you have a fixed size title block ours was always at 0,0 and 1:1 size then do a move window, way past the junk use extmax then erase the window of previous extmin extmax move your title block back all done.

Again if you have a title block scaled then you can still work out a move window of just the title block as you know its true size.
A man who never made a mistake never made anything

cmwade77

  • Swamp Rat
  • Posts: 1271
Re: Erase Outside Title Block
« Reply #2 on: July 22, 2021, 11:05:17 AM »
The quick and dirty if you have a fixed size title block ours was always at 0,0 and 1:1 size then do a move window, way past the junk use extmax then erase the window of previous extmin extmax move your title block back all done.

Again if you have a title block scaled then you can still work out a move window of just the title block as you know its true size.
A fixed size title block would be simple, unfortunately we have to use client title blocks that can range anywhere from 8.5x11 on up to 36x48, sometimes larger.

BIGAL

  • Swamp Rat
  • Posts: 769
  • 30 + years of using Autocad
Re: Erase Outside Title Block
« Reply #3 on: July 22, 2021, 10:58:23 PM »
Can still be done as you know the name and the size of the title block, so can still get a window size and location. If they are blocks can also use bounding box to find the title window. You may just have to provide  title block name/s.
A man who never made a mistake never made anything

cmwade77

  • Swamp Rat
  • Posts: 1271
Re: Erase Outside Title Block
« Reply #4 on: Today at 11:10:10 AM »
Can still be done as you know the name and the size of the title block, so can still get a window size and location. If they are blocks can also use bounding box to find the title window. You may just have to provide  title block name/s.
That is the issue, programmatically, I don't have anyway to know what size the title block is that I can think of that doesn't involve ActiveX. If I could read page setups without ActiveX, that might be a way around that though.

ronjonp

  • Needs a day job
  • Posts: 7305
Re: Erase Outside Title Block
« Reply #5 on: Today at 12:57:54 PM »
Can still be done as you know the name and the size of the title block, so can still get a window size and location. If they are blocks can also use bounding box to find the title window. You may just have to provide  title block name/s.
That is the issue, programmatically, I don't have anyway to know what size the title block is that I can think of that doesn't involve ActiveX. If I could read page setups without ActiveX, that might be a way around that though.
Maybe you can use this: (dictsearch (namedobjdict) "ACAD_LAYOUT")

Windows 10 x64 - AutoCAD /C3D 2020

Custom Build PC

cmwade77

  • Swamp Rat
  • Posts: 1271
Re: Erase Outside Title Block
« Reply #6 on: Today at 01:05:42 PM »
I have something that seems to be working, perhaps some people can kick the tires as it were to let me know where issues may exist?

Code: [Select]
;Code adapted from LeeMac's code at: http://www.theswamp.org/index.php?topic=43352.msg507568#msg507568
(defun EraseOutsideTitleBlock (/ SS BOX SS_ALL SS_KEEP LLP URP ENT idx flg tab)
 
  (defun DTR (a) ;degrees to radians function
    (* PI (/ a 180.0))
  );defun
 
  (defun CW:BoundingBox (ss / psize i EntType LLP URP PT2)
    ; get paper size on current tab - Adapted from JTB World - https://jtbworld.com/autocad-pagesetup-lsp
    (defun papersize (/ psn scale)
      (setq
        psn (member '(100 . "AcDbPlotSettings")
        (dictsearch
          (cdr (assoc -1 (dictsearch (namedobjdict) "ACAD_LAYOUT")))
          (getvar "ctab")
        )
      )
      )
      (if (= (caadr psn) 1) ; Page Setup Name exist
        (progn (setq scale (if (= 0 (cdr (assoc 72 psn)))
          25.4
          1.0
              )
        )
        (list (/ (cdr (assoc 45 psn)) scale) (/ (cdr (assoc 44 psn)) scale))
       
        )
      )
    )
   
    (setq psize (papersize))
    (if psize
      (progn
        (repeat (setq i (sslength ss))
          (setq ent (entget (ssname ss (setq i (1- i))))
                EntType (cdr (assoc 0 ent))
                LLP (cdr (assoc 10 ent))
                PT2 (polar LLP (DTR 90.0) (cadr psize))
                URP (polar PT2 (DTR 0.0) (car psize))
          )
         
        )
      )
    )
    (if (and llp urp)
      (list LLP URP)
    )
  )
 
 
  (setq tab (getvar "ctab"))
  (if (setq SS (ssget "_X" (list '(0 . "INSERT") '(8 . "$TB") (cons 410 tab))))
    (progn
      (setq BOX (CW:BoundingBox SS)
            LLP (car BOX)
            URP (cadr BOX)
            SS_ALL (ssget "_X" (list (cons 410 tab)))
            SS_KEEP (ssget "_W" (mapcar '- llp '(1e-2 1e-2)) (mapcar '+ urp '(1e-2 1e-2)) (list (cons 410 tab)))
      )
      (if (and (/= SS_ALL nil) (/= SS_KEEP nil))
        (progn
          (command "._-layer" "_unlock" "*" "")
          (repeat (setq idx (sslength SS_all))
            (if
                (not
                    (or (ssmemb (setq ent (ssname SS_all (setq idx (1- idx)))) SS_KEEP)
                        (or
                            (= "$$tbinfo" (cdr (assoc 8 (entget ent))))
                            (= "$tbinfo" (cdr (assoc 8 (entget ent))))
                        )
                    )
                )
                (progn
                    (entdel ent)
                    (or flg (setq flg (princ "\nObject(s) found outside the title block and will now be deleted.")))
                )
            )
          )
        )
      )
    )
  )
  (princ)
)