Jump to content

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

3dwannab

By 3dwannab
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

fuccaro Veteran

fuccaro

Posted
Posted 
(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...

  • Like 2
  • Thanks 1
Link to comment
Share on other sites
3dwannab Proficient

3dwannab

Posted
  • Author
Posted (edited)

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 by 3dwannab
Link to comment
Share on other sites
Steven P Grand Master

Steven P

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

  • Like 1
Link to comment
Share on other sites
mdchuyen Apprentice

mdchuyen

Posted
Posted
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

Link to comment
Share on other sites
3dwannab Proficient

3dwannab

Posted
  • Author
Posted (edited)

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 by 3dwannab
  • Like 1
Link to comment
Share on other sites
mdchuyen Apprentice

mdchuyen

Posted
Posted
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)"

Link to comment
Share on other sites
3dwannab Proficient

3dwannab

Posted
  • Author
Posted (edited)

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 by 3dwannab
Link to comment
Share on other sites
Steven P Grand Master

Steven P

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

 

  • Funny 2
Link to comment
Share on other sites
ronjonp Grand Master

ronjonp

Posted
Posted (edited)
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 by ronjonp
  • Thanks 1
Link to comment
Share on other sites
  • 4 months later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 Share
Go to topic listing
×
×
  • Create New...