BK_Hatch_Solid_With_Wipeout.lsp - Select suitable objects inside the block editor and hatch them

[3dwannab]

Hi all,

 

Here's the code I have to hatch items inside blocks with a wipeout layer. Handy for furniture and the like.

 

I was wondering if there was a more robust way of selecting objects in the block editor to hatch them.

 

See line:

(setq ssObj2Hat (ssget "_X" '((0 . "~*TEXT") (0 . "~ATTDEF")))) ;; Select all but TEXT, MTEXT or ATTDEF (Testing)

 

I've removed all text and attributes because they're those objects I would like to remove.

 

I'd like to get your guys thoughts on how best to tackle this, thanks. If nothing else share this with you all 

 

(vl-load-com)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; BK_Hatch_Solid_With_Wipeout.lsp
;; Hatches objects inside blocks with a SOLID hatch and on the "GN_wipe-out" layer.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Based on code by Tharwat 18th Sept 2013
;; https://www.cadtutor.net/forum/topic/46782-deleting-hatch-from-blocks/?do=findComment&comment=396412
;;
;; First modified on 2022.12.12 by 3dwannab to hatch everything inside the block. Help over here: https://www.cadtutor.net/forum/topic/76450-hatch-objects-inside-a-block/
;; Last modified on 2024.05.22 by 3dwannab
;;
;; Requires the _createOrUpdateLayer function located in the acaddoc.lsp file.
;;
;; TO DO: Only hatch entities that can be hatched. Think there may be a vla-get for this. Not sure.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:BKHatch_Solid_With_Wipeout (/ *error* acDoc blkn cnt i layerName obj ssHatches ssIns ssObj2Hat var_cmdecho var_osmode) 

  (defun *error* (errmsg) 
    (and acDoc (vla-EndUndoMark acDoc))
    (and errmsg 
         (not (wcmatch (strcase errmsg) "*CANCEL*,*EXIT*"))
         (princ (strcat "\n<< Error: " errmsg " >>\n"))
    )
    (setvar 'cmdecho var_cmdecho)
    (setvar 'osmode var_osmode)
  )

  ;; Start the undo mark here
  (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))

  ;; Get any system variables here
  (setq var_cmdecho (getvar "cmdecho"))
  (setq var_osmode (getvar "osmode"))
  (setvar 'cmdecho 0)
  (setvar 'osmode 0)

  (setq layerName "GN_wipe-out")

  (prompt (strcat "\nSelect BLOCKS to solid hatch in the layer '" layerName "' :\n"))
  (if (setq ssIns (ssget "_:L" '((0 . "INSERT")))) 
    (progn 

      (setq cnt 0)
      (repeat (setq cnt (sslength ssIns)) 
        (setq cnt (1- cnt))
        (setq blkn (cons (vla-get-effectivename (vlax-ename->vla-object (_dxf -1 (entget (ssname ssIns cnt))))) blkn))
      )

      (setq blkn (_removedup blkn))

      (foreach x blkn 

        (command "-bedit" x)

        (setvar 'cmdecho 0) ; Set this inside block editor just in case.
        (setvar 'osmode 0) ; Set this inside block editor just in case.

        (setq ssHatches (ssadd))
        ; (setq ssObj2Hat (ssget "_X" '((0 . "LWPOLYLINE") (-4 . "<OR") (70 . 1) (70 . 129) (-4 . "OR>")))) ;; Select closed polylines
        (setq ssObj2Hat (ssget "_X" '((0 . "~*TEXT") (0 . "~ATTDEF")))) ;; Select all but TEXT, MTEXT or ATTDEF (Testing)

        (if ssObj2Hat 
          (progn 

            ;; Create the wipe out layer
            (_createOrUpdateLayer layerName '(254 254 254) "Continuous" acLnWt025 0 :vlax-true "Craftstudio Layer - General Layer: Useful for furniture and other movable objects to obscure whats behind")

            (command "_.-hatch" "_P" "_S" "_LA" "." "_advanced" "_associativity" "_yes" "" "_select" ssObj2Hat "" "")

            ;; Add the created hatches to a selection set.
            (setq ssHatches (ssadd (entlast) ssHatches))

            ;; Loop through selected objects and set properties
            (repeat (setq i (sslength ssHatches)) 
              (setq obj (vlax-ename->vla-object (ssname ssHatches (setq i (1- i)))))

              ;; Set the hatch objects to the correct properties for the 'GN_wipe-out' layer.
              (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Layer (list obj layerName)))
              (vl-catch-all-error-p (vl-catch-all-apply 'vla-put-Linetype (list obj "ByLayer")))
              (vla-put-LineWeight obj aclnwtbylayer)
              (vla-put-Color obj acbylayer)
              (vla-put-LinetypeScale obj 1)
              (vla-put-EntityTransparency obj "ByBlock")
            )

            ;; Send behind the selected objects.
            (command "_.draworder" ssHatches "" "_U" ssObj2Hat "")
          )
        ) ; if ssObj2Hat

        (command "_.bsave")
        (command "_.bclose")
        (redraw)
      ) ; foreach
    ) ; progn
  )
  (if ssIns 
    (progn 
      (princ (strcat "\n: ------------------------------\n\t\t<<< " (itoa (sslength ssIns)) (if (> (sslength ssIns) 1) " <<< BLOCKS" " <<< BLOCK") " solid hatched with layer '" layerName "'\n: ------------------------------\n"))
      (sssetfirst nil ssIns)
      (command "_.regen")
    )
  )
  (vla-EndUndoMark acDoc)
  (*error* nil)
  (princ)
)

;; removes duplicate element from the list
(defun _removedup (l) 
  (if l 
    (cons (car l) (_removedup (vl-remove (car l) (cdr l))))
  )
)

;;----------------------------------------------------------------------;;
;; _dxf
;; Finds the association pair, strips 1st element
;; args   - dxfcode elist
;; Example  - (_dxf -1 (entget (ssname (ssget) 0)))
;; Returns  - <Entity name: xxxxxxxxxxx>

(defun _dxf (code elist) 
  (cdr (assoc code elist))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; _createOrUpdateLayer
;;
;; Creates a new layer or updates an existing one if it exists.
;; Will attempt to load the linetype if found in the acad*.lin file and if the layer exists, it will update the properties.
;; Original code by ronjonp, taken from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/create-layer-with-true-color-in-lisp/m-p/7904814#M367339
;;
;; USAGE:
;; (_createOrUpdateLayer "Test1" 22 "Dashed" aclnwtbylwdefault 33 :vlax-true "Test1 Description")
;; (_createOrUpdateLayer "Test2" '(100 150 200) "Continuous" aclnwtbylwdefault 33 :vlax-false "Test2 Description")
;;
;; The :vlax-true or :vlax-false in examples above is for plot on or off.
;; The 33 values represent the transparency of the layer.
;; Original help from mhupp here to get it to update layer if it exists: https://www.cadtutor.net/forum/topic/75414-defun-to-create-or-update-layers-not-updating-them/?do=findComment&comment=596266
;;
;; ARGUMENTS:                                ARGUMENTS SYTAX:
;; 1st arg: Layers Name                  =   STRING
;; 2nd arg: Layers Colour                =   22 or '(100 150 200) (Can be an indexed colour or true colour)
;; 3rd arg: Layers Linetype              =   STRING
;; 4th arg: Layers Lineweight            =   acLnWtByLayer, acLnWtByBlock, acLnWtByLwDefault, acLnWt000, acLnWt005, acLnWt009, acLnWt013, acLnWt015, acLnWt018, acLnWt020, acLnWt025, acLnWt030, acLnWt035, acLnWt040, acLnWt050, acLnWt053, acLnWt060, acLnWt070, acLnWt080, acLnWt090, acLnWt100, acLnWt106, acLnWt120, acLnWt140, acLnWt158, acLnWt200, acLnWt211
;; 5th arg: Layers Transparency          =   INTEGER (Between 0-90)
;; 6th arg: Layers is Plottable on not   =   :vlax-true = Plottable or :vlax-false = Not Plottable
;; 7th arg: Layers Description           =   STRING
;;
;; For Linewiight in vlisp, see this reply by CAB: https://www.theswamp.org/index.php?topic=22438.msg270124#msg270124
;;
;; MODIFICATIONS:
;; New code By Leemac with small modifications by 3dwannab.
;; Modified by 3dwannab on 2024.05.22 to add if the layers is plottable and also added the possibility to add a description to the layer.
;; Lee Macs code: https://www.cadtutor.net/forum/topic/66765-vla-put-truecolor/?do=findComment&comment=546879
;; Modified by 3dwannab on 2024.05.22 to add transparency, description and plot to Lee Macs function.
;; Help from mhupp here to get it to update layer if it exists: https://www.cadtutor.net/forum/topic/75414-defun-to-create-or-update-layers-not-updating-them/?do=findComment&comment=596266

(defun _createOrUpdateLayer (name color linetype lineweight transparency plottable description / _loadlinetype lay tru) 

  ;; Credit to Grr1337
  ;; https://www.theswamp.org/index.php?topic=52473.msg574008#msg574008
  ;; (_SetLayerTransparency (getvar 'clayer) 90)
  (defun _SetLayerTransparency (LayerName Transparency / lyr) 
    (and 
      (<= 0 Transparency 90)
      (setq lyr (tblobjname "LAYER" LayerName))
      (not (setpropertyvalue lyr "Transparency" Transparency))
      (not (entupd lyr))
    )
  )

  (defun _loadlinetype (ltype / lt out) 
    (cond 
      ((tblobjname "ltype" ltype) t)
      ((setq lt (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object))))
       (setq out (vl-catch-all-apply 
                   'vla-load
                   (list lt 
                         ltype
                         (findfile 
                           (if (= 0 (getvar 'measurement)) 
                             "acad.lin"
                             "acadiso.lin"
                           )
                         )
                   )
                 )
       )
       (not (vl-catch-all-error-p out))
      )
    )
  ) ;; defun _loadlinetype

  ;; Set the layer properties
  (setq lay (vla-add (vla-get-layers (vla-get-activedocument (vlax-get-acad-object))) name)) ;; 1st arg
  (if (listp color) 
    (progn 
      (setq tru (vla-get-truecolor lay))
      (apply 'vla-setrgb (cons tru color))
      (vla-put-truecolor lay tru)
    )
    (vla-put-color lay color) ;; 2nd arg
  )
  (vla-put-linetype lay 
                    (if (_loadlinetype linetype) 
                      linetype
                      "continuous"
                    )
  ) ;; 3rd arg
  (vla-put-lineweight lay lineweight) ;; 4th arg
  (_SetLayerTransparency name transparency) ;; 5th arg
  (vla-put-Plottable lay plottable) ;; 6th arg
  (vla-put-description lay description) ;; 7th arg
  lay
) ;; end _createOrUpdateLayer defun

; (c:BKHatch__Solid_With_Wipeout)

 

Edited May 23 by 3dwannab