Hatch to each of the closed polylines (Match the colour, Layer)

[3dwannab]

Hi all, there's no point in reinventing the wheel. I was looking to see if there's a program to hatch each of the closed polylines to match each layer and colour.

 

I'm doing a schedule for each room so this would be fairly handy.

 

Thanks in advance.

Solid Hatch Each Boundary With Properties of Boundary.dwg

[fuccaro]

(defun c:MyHatch()
  (setq ss (ssget "X" (list '(0 . "LWPOLYLINE") '(70 . 1))))
  (repeat (setq i (sslength ss))
    (setq p (ssname ss (setq i (1- i))))
    (setq pl (entget p)
	  lay (assoc 8 pl)
	  color (assoc 62 pl)
	  )
    (command "_hatch" "s" p "")
    (setq hatch (entget (entlast))
	  hatch (subst lay (assoc 8 hatch) hatch)	  
	  )
    
    (cond
      (color (setq hatch (append hatch (list color))))
      )
    
    (entmod hatch)
    )
   (setq ss nil)
  )

Just a quick one...

[3dwannab]

Thanks very much @fuccaro. I added undo handling and used the ":L" ssget to get preselection or selection.

 

Here's that if anyone wants it.

 

(vl-load-com)

;; See thread here: https://www.cadtutor.net/forum/topic/77467-hatch-to-each-of-the-closed-polylines-match-the-colour-layer/

;; Program to hatch closed polylines to match the layer and colour of each selection polyline.
;; Answer by fuccaro and added undo handling and changed the selection method by myself (3dwannab)

;; First written on 2023.05.11

(defun c:HBC nil (c:HH_Boundary_Colour))

(defun c:HH_Boundary_Colour (/ *error* acDoc hatch i p pl ss1 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)
  )

  (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))

  (setq var_cmdecho (getvar "cmdecho"))
  (setq var_osmode (getvar "osmode"))

  (setvar 'cmdecho 0)
  (setvar 'osmode 0)

  (setq ss1 (ssget ":L" (list '(0 . "LWPOLYLINE") '(70 . 1))))
  (repeat (setq i (sslength ss1)) 
    (setq p (ssname ss1 (setq i (1- i))))
    (setq pl    (entget p)
          lay   (assoc 8 pl)
          color (assoc 62 pl)
    )
    (command "_hatch" "s" p "")
    (setq hatch (entget (entlast))
          hatch (subst lay (assoc 8 hatch) hatch)
    )

    (cond 
      (color (setq hatch (append hatch (list color))))
    )

    (entmod hatch)
  )

  (*error* nil)
  (princ)
)

(princ (strcat " \n: ------------------------------\n'Hatch_Boundary_Colour.lsp' Loaded | Invoke by typing 'HH_Boundary_Colour' or 'HBC'.\n: ------------------------------\n"))
(princ)

 

Edited May 11, 2023 by 3dwannab

[fuccaro]

Glad to be helped.

Not a big deal, but I would add at the end 

(setq ss1 nil)

Have a good day!

[3dwannab]

Does localising the selection set not do the same?

[fuccaro]

Yes, defining SS1 as local variable, it will be destroyed once the function exits.

[Steven P]

19 hours ago, 3dwannab said:

Does localising the selection set not do the same?

 

Usually better this way in case SS1 has been used in another LISP as a global variable (not localised)

[mdchuyen]

On 5/11/2023 at 5:39 PM, 3dwannab said:

Thanks very much @fuccaro. I added undo handling and used the ":L" ssget to get preselection or selection.

 

Here's that if anyone wants it.

 

(vl-load-com)

;; See thread here: https://www.cadtutor.net/forum/topic/77467-hatch-to-each-of-the-closed-polylines-match-the-colour-layer/

;; Program to hatch closed polylines to match the layer and colour of each selection polyline.
;; Answer by fuccaro and added undo handling and changed the selection method by myself (3dwannab)

;; First written on 2023.05.11

(defun c:HBC nil (c:HH_Boundary_Colour))

(defun c:HH_Boundary_Colour (/ *error* acDoc hatch i p pl ss1 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)
  )

  (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))

  (setq var_cmdecho (getvar "cmdecho"))
  (setq var_osmode (getvar "osmode"))

  (setvar 'cmdecho 0)
  (setvar 'osmode 0)

  (setq ss1 (ssget ":L" (list '(0 . "LWPOLYLINE") '(70 . 1))))
  (repeat (setq i (sslength ss1)) 
    (setq p (ssname ss1 (setq i (1- i))))
    (setq pl    (entget p)
          lay   (assoc 8 pl)
          color (assoc 62 pl)
    )
    (command "_hatch" "s" p "")
    (setq hatch (entget (entlast))
          hatch (subst lay (assoc 8 hatch) hatch)
    )

    (cond 
      (color (setq hatch (append hatch (list color))))
    )

    (entmod hatch)
  )

  (*error* nil)
  (princ)
)

(princ (strcat " \n: ------------------------------\n'Hatch_Boundary_Colour.lsp' Loaded | Invoke by typing 'HH_Boundary_Colour' or 'HBC'.\n: ------------------------------\n"))
(princ)

 

can you add hatch type option? It is defaulting to hatch solid

[BIGAL]

Big hint (setvar 'hpname "Ansi31")

[3dwannab]

Just need to fix the hatch as it was non-associative.

 

Here's that fix

; (command "_hatch" "s" p "") ;; Original hatch command. Created a non-associative hatch

(command "-hatch" "P" "SOLID" "A" "A" "Y" "" "T" "." "S" p "" "") ;; Working for solid hatch with asssocitivity

 

@mdchuyen, to hatch with pattern name:

(command "-hatch" "P" "Ansi31" "555" "0" "A" "A" "Y" "" "T" "." "S" p "" "") ;; Hatch with pattern name where scale is 555.

 

Edited May 16, 2023 by 3dwannab

[mdchuyen]

1 hour ago, 3dwannab said:

Just need to fix the hatch as it was non-associative.

 

Here's that fix

; (command "_hatch" "s" p "") ;; Original hatch command. Created a non-associative hatch

(command "-hatch" "P" "SOLID" "A" "A" "Y" "" "T" "." "S" p "" "") ;; Working for solid hatch with asssocitivity

 

@mdchuyen, to hatch with pattern name:

(command "-hatch" "P" "Ansi31" "555" "0" "A" "A" "Y" "" "T" "." "S" p "" "") ;; Hatch with pattern name where scale is 555.

 

may appear table to choose "(initdia)"

[3dwannab]

I wonder what the easiest way to get the hatch to go to a true colour is if the polyline is. 

 

This is my brute-force method.

(command "_.matchprop" "_non" p "_non" (entlast) "")

 

Is there a variable or registry value for match prop settings. It was asked before on theswamp but that thread is 12 year old. https://www.theswamp.org/index.php?topic=37406.0

 

I'm sure there was one and I had it in one of my programs but can't find it anywhere.

Edited May 17, 2023 by 3dwannab

[Steven P]

(command "chprop" (ssget "_:L-I") "" "COLOR" "t" "255,51,204" "")

 

(Crayola Razzle Dazzle Rose colour....)

 

 

and I don't care,. this is the lisp name, like it or not,.

 

 

(defun c:Lauper ( / ) ; True colours.
  (setq MyEnt (car (entsel)))
  (setq MyObj (vlax-ename->vla-object MyEnt))
;;https://adndevblog.typepad.com/autocad/2012/12/accessing-the-truecolor-property-using-visual-lisp.html
  (setq oColor (vlax-get-property MyObj 'TrueColor)
      clrR (vlax-get-property oColor 'Red)
      clrG (vlax-get-property oColor 'Green)
      clrB (vlax-get-property oColor 'Blue)
  )
;;Match colour
  (princ "Thanks, select objects to change")
  (command "chprop" (ssget "_:L-I") "" "COLOR" "t" (strcat (rtos clrR) "," (rtos clrG) "," (rtos clrB)) "")
)

 

[ronjonp]

On 5/17/2023 at 9:25 AM, 3dwannab said:

I wonder what the easiest way to get the hatch to go to a true colour is if the polyline is. 

 

This is my brute-force method.

(command "_.matchprop" "_non" p "_non" (entlast) "")

 

Is there a variable or registry value for match prop settings. It was asked before on theswamp but that thread is 12 year old. https://www.theswamp.org/index.php?topic=37406.0

 

I'm sure there was one and I had it in one of my programs but can't find it anywhere.

Give this a try. It will match INDEX, RGB and COLORBOOK as well as match the LAYER NAME. It has the added benefit of also leaving bylayer colors intact.

(defun c:foo (/ f h o s sp)
  ;; RJP » 2023-05-18
  (cond
    ((setq s (ssget '((0 . "CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))))
     (setq sp (vlax-ename->vla-object (cdr (assoc 330 (reverse (entget (ssname s 0)))))))
     (foreach e	(vl-remove-if 'listp (mapcar 'cadr (ssnamex s)))
       (cond ((vlax-curve-isclosed e)
	      (setq h (vlax-invoke sp 'addhatch achatchobject "SOLID" :vlax-true))
	      (vlax-invoke h 'appendouterloop (list (vlax-ename->vla-object e)))
	      (setq f (vl-remove-if-not '(lambda (x) (member (car x) '(8 62 420 430))) (entget e)))
	      ;; Match layer and byobject colors
	      (entmod (append (entget (vlax-vla-object->ename h)) f))
	      (vla-evaluate h)
	     )
       )
     )
    )
  )
  (princ)
)

 

Edited May 18, 2023 by ronjonp

[3dwannab]

Never even thought of colour book @ronjonp. Thanks. 

 

This is proving a very handy tool.

 

Ps. I do like the name @Steven P. 

[3dwannab]

@ronjonp Is there any way to get the properties of transparency and apply them properties also?

[ronjonp]

@3dwannab add 440 to this list: '(8 62 420 430 440)

[3dwannab]

Added the ability to select a hatch after creation of hatches to match the new ones.

 

(vl-load-com)

;;
;; See thread here: https://www.cadtutor.net/forum/topic/77467-hatch-to-each-of-the-closed-polylines-match-the-colour-layer/
;;
;; Program to hatch objects in the ssget filter below to match the layer, colour and transparency of each object.
;; Answer by fuccaro and added undo handling and changed the selection method by myself (3dwannab)
;;
;; NOTE: The _createOrUpdateLayer function is located in the acaddoc.lsp file.
;;
;; First written on 2023.05.11
;; Last modified on 2024.06.04 by 3dwannab
;; Last modified on 2024.06.04 by 3dwannab - Added the ability to select a hatch after creation of hatches to match the new ones.
;;

(defun c:HBC nil (c:HH_Boundary_Colour))

(defun c:HH_Boundary_Colour (/ *error* acDoc bdata entH f hObj layerName sp ssPolyClosed ssSelHatch 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)
  )

  (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (or (vla-EndUndoMark acDoc) (vla-StartUndoMark acDoc))

  (setq var_cmdecho (getvar "cmdecho"))
  (setq var_osmode (getvar "osmode"))

  (setvar 'cmdecho 0)
  (setvar 'osmode 0)

  (setq ssSelHatch (ssadd))

  ;; RJP » 2023-05-18
  (cond 
    ((setq ssPolyClosed (ssget "_:L" '((0 . "CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))))
     (setq sp (vlax-ename->vla-object (cdr (assoc 330 (reverse (entget (ssname ssPolyClosed 0)))))))
     (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssPolyClosed))) 
       (cond 
         ((vlax-curve-isclosed e)

          (setq hObj (vlax-invoke sp 'addhatch achatchobject "SOLID" :vlax-true))
          (vlax-invoke hObj 'appendouterloop (list (vlax-ename->vla-object e)))
          (setq f (vl-remove-if-not '(lambda (x) (member (car x) '(8 62 420 430 440))) (entget e)))
          ;; Match layer and byobject colors
          (entmod (append (entget (vlax-vla-object->ename hObj)) f))

          (vla-evaluate hObj)

          ;; Put transparency to the new hatch if it matches a certain layer name. This is is for the "AN_revision" layer.
          ;; Added by 3dwannab on 2024.05.09
          (if 
            (or 
              (and hObj (wcmatch (cdr (assoc 8 (entget e))) "*rev*"))
              (and hObj (wcmatch (cdr (assoc 8 (entget e))) "*boundary*"))
            )
            (vla-put-EntityTransparency hObj "85")
          )

          ;; Put layer to "CH_existing" to the new hatch if it matches a wildcard layer with *existing* in it.
          ;; Added by 3dwannab on 2024.06.21
          (if (and hObj (wcmatch (cdr (assoc 8 (entget e))) "*existing*")) 

            (progn 
              (setq layerName "CH_existing")
              ;; Create a layer, this defun is in the acaddoc.lsp file
              (_createOrUpdateLayer layerName '(130 130 130) "Continuous" acLnWtByLwDefault 50 :vlax-true "Craftstudio Layer - Colour Hatch Layer")

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

          ;; Put layer to "GN_wipe-out" to the new hatch if it matches a certain layer name
          ;; Added by 3dwannab on 2024.05.21
          (if (and hObj (wcmatch (cdr (assoc 8 (entget e))) "0")) 

            (progn 
              (setq layerName "GN_wipe-out")
              ;; Create a layer, this defun is in the acaddoc.lsp file
              (_createOrUpdateLayer layerName '(254 254 254) "Continuous" 025 0 :vlax-true "Craftstudio Layer - General Layer: Useful for furniture and other movable objects to obscure whats behind")

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

          (setq ssSelHatch (ssadd (entlast) ssSelHatch))
         ) ;; end cond
       )
     )
    )
  )

  ;; Pick a hatch to match the properties to the newly created hatches
  ;; This will wait until the user selects a hatch
  (while 
    (not 
      (and 
        (setq entH (car (entsel "\nSelect the hatch to match properties from: ")))
        (setq bdata (if entH (entget entH)))
        (= (cdr (assoc 0 bdata)) "HATCH")
      )
    )
    (prompt "\nNothing selected, or it is not a HATCH -- ")
  )

  ;; If the hatch is selected do this
  (if entH 
    (command "_.matchprop" "_non" entH "_non" ssSelHatch "")
  )

  ;; If ssSelHatch, select the newly created hatches
  (if ssSelHatch 
    (progn 
      (princ (strcat "\n: ------------------------------\n\t\t<<< " (itoa (sslength ssSelHatch)) (if (> (sslength ssSelHatch) 1) " <<< HATCHES" " <<< HATCH") " created\n: ------------------------------\n"))
      (command "_.draworder" ssSelHatch "" "_B")
      (sssetfirst nil ssSelHatch)
      (command "_.regen")
    )
  )

  (vla-EndUndoMark acDoc)

  (*error* nil)
  (princ)
)

; (c:HBC) ;; UNblock for testing

(princ (strcat " \n: ------------------------------\n'Hatch_Boundary_Colour.lsp' Loaded | Invoke by typing 'HH_Boundary_Colour' or 'HBC'.\n: ------------------------------\n"))
        
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; _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
(princ)

 

Edited October 23 by 3dwannab