Draw Hatch command

[3dwannab]

Hi all, in 2025, it gave the ability to draw a hatch.

 

I was looking for a way to run this as a command. I don't know how to handle the pause in the code below.

 

I want to enter the hatch command and choose draw, then draw my boundary and then accept the last two options once this is done but my code only allows picking one point.

 

(command "-hatch" "_w" "_n" pause "" "")

 

Also, one other quirk I noticed is the code above sets osmode to 0.

 

Edit:

I guess this will do. But how can I check if the polyline was in actual fact drawn so I could delete it after drawing the hatch?

 

  (command-s "_.PLINE")
  (command "_.-hatch" "_P" "_S" "_LA" "." "_advanced" "_associativity" "_yes" "" "_select" "_last" "" "")

 

Edited July 23 by 3dwannab

[CyberAngel]

1 hour ago, 3dwannab said:

Edit:

I guess this will do. But how can I check if the polyline was in actual fact drawn so I could delete it after drawing the hatch?

 

  (command-s "_.PLINE")
  (command "_.-hatch" "_P" "_S" "_LA" "." "_advanced" "_associativity" "_yes" "" "_select" "_last" "" "")

 

 

This may be a little clunky, so one of our resident wizards can come along and improve it.

 

To remove your pattern pline, 1) store the last entity before you draw it 2) store the last entity after you draw it 3) create your hatch 4) compare those two entities 5) if they're different, erase the entity from step 2.

[3dwannab]

Thanks, @CyberAngel for the pointer.

 

This should do that trick:

(defun c:test (/ *error* acDoc en enLast ss var_cmdecho vertsLen) 

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

  ;; 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"))
  (setvar 'cmdecho 0)

  ;; Start main section of routine
  (command-s "_.PLINE")

  (while (< 0 (getvar (quote cmdactive))) 
    (command "\\")
  )

  (setq enLast (entlast))

  ;; https://forums.augi.com/showthread.php?162033-Select-the-last-N-entities-created-in-a-lisp-routine&p=1294770&viewfull=1#post1294770
  ;; Snippet of code to check entities created by the program and nothing else.
  (setq ss (ssadd))
  (if (setq en (entnext enLast))  ;; Check if there's a new entity created since the last one
    (while en  ;; Step through all new entities
      (ssadd en ss) ;; Add it to the selection set
      (setq en (entnext en)) ;; Get the next entity
    )
  )

  (if enLast (setq vertsLen (/ (length (vlax-get (vlax-ename->vla-object enLast) 'Coordinates)) 2)))

  (if 
    (and 
      enLast
      (> vertsLen 2) ;; Check if there's more than 2 vertices
    )

    (progn 

      ;; Auto closes the polyline if it's not already
      (if (not (vlax-curve-isclosed enLast)) 
        (vla-put-closed (vlax-ename->vla-object enLast) :vlax-true)
      )

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

  (vla-EndUndoMark acDoc)

  (*error* nil)
  (princ)
)

(c:test)

 

[marko_ribar]

@3dwannab

Hi OP...

I have a question...

Does that new HATCH command create *.pat file, or it uses something else? Is your newly created pattern in square matrix, or it could be also rectangular? I see that you liked my post in this topic, but no one downloaded ractangular pattern with dots - so method stayed uncommented... Link : https://www.cadtutor.net/forum/topic/70417-make-pat-files/page/4/#comments

[3dwannab]

Hi @marko_ribar, I'm very confused. Which new hatch command? Are you referring to the latest program you wrote on that thread?

[marko_ribar]

No, just I am watching this topic and I see that you are speaking ab AutoCAD 2025 which I don't have installed... So I was guessing that AutoDesk changed something in HATCH command itself - at least "_.-HATCH" (the one that starts with "-")... Or, I am guessing, you are using ToolPack that has HatchMaking option Toolbar and which I already uninstalled as it loads quite longly (I don't have supercomputer like you)...

[marko_ribar]

Ohh, I see it now...

You just want to make closed polyline and hatch it with Solid hatch... So my AutoCAD has this -HATCH also built-in...

[3dwannab]

@marko_ribar, that's it, see the below program, written by Charles but additions along the way by myself. It's similar to the MakeMore lisp.

 

The hatch section will allow the user to draw a hatch similar to that of the selected one.

 

Wow, you paid 300 odd euro for TP and uninstalled it? 

 

(vl-load-com)

;;;====================================================================;
;;;                     SetCurrent.lsp                                 ;
;;;                   Charles Alan Butler                              ;
;;;                 Updates CAB TheSwamp.org                           ;
;;;                     @ Copyright 2014                               ;
;;;                  Original routine 2003                             ;
;;;                Last edit by 3dwannab 2024                          ;
;;;====================================================================;
;;
;;  Revision 2004.17.06
;;  Revision 2004.28.06
;;    Added Leader detection & layer change for any object selected.
;;  Revision 2004.03.07
;;    Added cross check for leader to text & text to leader
;;  Revision 2008.05.04
;;    Fixed bug to properly set DimStyle from Leader Text
;;  Revision 2013.21.09
;;    Re-write of this routine, added tables, blocks & sub entities like attrubutes & text
;;    Added LineType to set current also
;;  Revision 2014.03.03
;;    Added pre selection for start up & set current Lcolor & Lweight if flag is set
;;  Revision 2014.03.07
;;    Added Truecolor to set current also
;;  Revision 2023.10.03 - 3dwannb edit
;;    Added Transparency to set current also
;;  Revision 2024.07.23 - 3dwannb edit
;;    Added Drawing of a hatch similar to the one selected using a polyline (3dwannb edit)
;;    Added Sets also the current Lineweight, Colour and transparency
;;    Added Undo handling
;;    Added Set the current transparency to "ByLayer" after the program has finished.
;;
;;  Routine to set current Layer, Text Style and/or Dim Style by
;;  picking an existing object in the drawing
;;
;;  OBJECT SELECTED         Set Current
;;  TEXT, MTEXT or Rtext    Layer, Text Style
;;  Attributes              Layer, Text Style
;;  Block sub objects       See object type
;;  Dimension               Layer, Dim Style
;;  Leader                  Layer, Dim Style
;;  Multiline Style         Layer, Style (Added by 3dwannab on 21/03/2019)
;;  Leader w/text           Layer, Dim & Text Style
;;  Text, mtext w/Leader    Layer, Dim & Text Style
;;  Any other object        Layer
;;
;;  Enter tds from the command line to run
;;  or set up a menu button with ^C^Ctds
;;
;;;====================================================================;
;;;  THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED      ;
;;;  WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR   ;
;;;  PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.             ;
;;;====================================================================;
;;;  Copyright 2014  by Charles Alan Butler. All Rights Reserved.      ;
;;;                                                                    ;
;;;  You are hereby granted permission to use, copy and modify this    ;
;;;  software without charge, provided you do so exclusively for       ;
;;;  your own use or for use by others in your organization in the     ;
;;;  performance of their normal duties, and provided further that     ;
;;;  the above copyright notice appears in all copies and both that    ;
;;;  copyright notice and the limited warranty and restricted rights   ;
;;;  notice below appear in all supporting documentation.              ;
;;;                                                                    ;
;;;  Incorporation of any part of this software into other software,   ;
;;;  except when such incorporation is exclusively for your own use    ;
;;;  or for use by others in your organization in the performance of   ;
;;;  their normal duties, is prohibited without the prior written      ;
;;;  consent of Charles Alan Butler, 1403 Duelda Drive,                ;
;;;  Brandon Florida, 33511                                            ;
;;;                                                                    ;
;;;  Copying, modification and distribution of this software or any    ;
;;;  part thereof in any form except as expressly provided herein is   ;
;;;  prohibited without the prior written consent of Charles Alan      ;
;;;  Butler, 1403 Duelda Drive, Brandon Florida, 33511                 ;
;;;                                                                    ;
;;;====================================================================;

(defun c:tds nil (c:SetCurrent))

(defun c:SetCurrent (/ *error* acDoc ent ss var_cmdecho) 

  (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 'cetransparency -1) ;; Set the current transparency back to ByLayer, annoying if this is left
  )

  ;; 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"))
  (setvar 'cmdecho 0)

  (cond 
    ;; if ss is a pick set and has object(s)  (03.02.14)
    ((and (setq ss (cadr (ssgetfirst))) 
          (= (type ss) 'pickset)
          (/= 0 (sslength ss))
          (setq ent (ssname ss 0))
     ) ; get the first object
     (CAB:SetCurrent ent nil)
    )
    ((or ent (null (setq ent (entsel "\nSelect Object to make settings current: "))))
     (princ "\nNothing Selected.")
    )

    ;((and (vl-position (cdr (assoc 0 (setq entbl (entget (car ent))))) '("INSERT" "TABLE" "MLEADER"))
    ;      )
    ;)

    ((and ent (CAB:SetCurrent ent nil)))
  ) ; end cond

  (vla-EndUndoMark acDoc)

  (*error* nil)
  (princ)
) ;; End defun SetCurrent

(defun CAB:SetCurrent (ent flags / a e elst en enLast enLastHatch ent entbl height idx layname LayName LColor ltype LWeight obj obj2 objname ObjName objname2 ObjName2 pkpt plWidth plWidthOrg pnt1 ss style usercmd vertsLen) 

  ;;  Returns property or nil
  (defun get-property (obj prop) 
    (if (vlax-property-available-p obj prop) 
      (vlax-get obj prop)
    )
  )
  ;;
  (defun set-current (prop value / err) 
    (cond 
      ((null value)
       (princ (strcat "\nError: Setting " prop " failed, null value.\n"))
      )
      ((= value (getvar prop))) ; no change
      ((= prop "DimStyle")
       (if 
         (vl-catch-all-error-p 
           (setq err (vl-catch-all-apply '(lambda () (apply 'command (list prop "_R" value)))))
         )
         (princ (strcat "\nError: Setting " prop " failed to set.\n" (vl-catch-all-error-message err)))
         (prompt (strcat "\n*-* Changed " prop " to: " (vl-princ-to-string value)))
       )
      )
      ((if 
         (vl-catch-all-error-p 
           (setq err (vl-catch-all-apply 'setvar (list prop value)))
         )
         (princ (strcat "\nError: Setting " prop " failed to set.\n" (vl-catch-all-error-message err)))
         (prompt (strcat "\n*-* Changed " prop " to: " (vl-princ-to-string value)))
       )
      )
    )
    (princ "\n") ;; Adds a newline after the last property has been printed
  )

  (defun set:dim:style (elst) 
    (setq d:styold (getvar "dimstyle"))
    (command "-dimstyle" "restore" (cdr (assoc 3 elst)))
    (setq d:stynew (getvar "dimstyle"))
  )

  ;; Sets the current Layer, Lineweight, Colour, Linetype and transparency
  ;; Modified by 3dwannab on 2024.07.23
  (defun set:Layer:Colour:LType:LWeight:Trans (obj) 
    ;; Set current Layer
    (set-current "clayer" (get-property obj 'Layer))
    ;; Set current Colour
    (setq ent (entget (vlax-vla-object->ename obj)))
    (set-current "cecolor" (GetColor ent))
    ;; Set current Linetype
    (if (not (vl-position (setq ltype (get-property obj 'Linetype)) '("ByLayer"))) 
      (set-current "celtype" ltype)
      (if (/= (getvar "celtype") "ByLayer") 
        (set-current "celtype" "ByLayer")
      )
    )
    ;; Set current Lineweight
    (set-current "celweight" (get-property obj 'LineWeight))
    ;; Set current transparency
    ;; https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/get-object-transparency-by-pick/m-p/10628172#M420628
    (setvar 
      'cetransparency
      (cond 
        ((numberp (read (setq a (vlax-get obj 'entitytransparency))))
         (read a)
        )
        ((cadr (assoc a '(("ByLayer" -1) ("ByBlock" -2)))))
      )
    )
  )

  (if (listp ent) 
    (setq pkpt (cadr ent)
          ent  (car ent)
    )
  )

  ;; Convert TrueColor into a string "RGB:185,230,25"
  (defun OLEtoRGB_color (OLE_color / r g b) 
    (setq r (lsh OLE_color -16))
    (setq g (lsh (lsh OLE_color 16) -24))
    (setq b (lsh (lsh OLE_color 24) -24))
    (strcat "RGB:" (itoa r) "," (itoa g) "," (itoa b))
  )

  (defun GetColor (en / c) 
    (cond 
      ((setq c (cdr (assoc 420 en))) ; get the color "RGB:185,230,25"
       (setq c (OLEtoRGB_color c))
      )
      ((setq c (cdr (assoc 62 en))) ; get the color
      )
      ((setq c "byLayer"))
    )
    c
  )

  ;;---------------------------------------------------
  ;;  **************  Begin Routine  ******************
  ;;---------------------------------------------------

  (if (and ent (setq entbl (entget ent))) 
    (progn 
      (setq usercmd (getvar "CMDECHO"))
      (setvar "CMDECHO" 0)
      (command "undo" "begin")

      (setq obj (vlax-ename->vla-object ent))
      (setq ObjName (get-property obj 'ObjectName))
      (prompt (strcat "\n*-* Object selected: " ObjName))

      (setq LayName (get-property obj 'Layer))

      ;; Sets the current Layer, Lineweight, Colour, Linetype and transparency
      (set:Layer:Colour:LType:LWeight:Trans obj)

      (= LColor 0)
      (cond 

        ;; ============================================================
        ((and pkpt (vl-position ObjName '("AcDbBlockReference" "AcDbTable")))

         (set:Layer:Colour:LType:LWeight:Trans obj)
         (setq LWeight (get-property obj 'Lineweight))
         (setq LColor (GetColor entbl)) ; get the color "RGB:185,230,25"

         ;  Removed the ability to get
         ;  if table and block get sub entitiy
         (if (setq e (nentselp pkpt)) 
           (cond 
             ((vl-position 
                (setq ObjName2 (get-property (setq obj2 (vlax-ename->vla-object (car e))) 'ObjectName))
                '("AcDbAttribute" "AcDbMText" "AcDbText")
              )
              (set-current "TextSize" (get-property obj2 'Height))
              (set-current "TextStyle" (get-property obj2 'StyleName))
              ;  (set:Layer:Colour:LType:LWeight:Trans obj2)
              ; (setq LColor (GetColor (entget (car e))))
              ;  (setq LColor (GetColor entbl))
             )
             ; (t ; picked the Table or Block border or grid
             ;  (set:Layer:Colour:LType:LWeight:Trans obj)
             ;  (set-current "CTableStyle" (get-property obj 'StyleName))
             ;  ; (setq LColor (GetColor (entget (car e))))
             ;  (setq LColor (GetColor entbl))
             ; )
           )
         )
        )

        ;; ============================================================
        ((vl-position ObjName '("AcDbLeader" "AcDbMLeader")) ; found a leader
         (set:Layer:Colour:LType:LWeight:Trans obj)
         (set-current "DimStyle" (get-property obj 'StyleName))
         (if 
           (and (setq obj2 (get-property obj 'Annotation)) 
                (setq style (get-property obj2 'StyleName))
                (setq height (get-property obj2 'Height))
           )
           (progn 
             (set-current "TextSize" height)
             (set-current "TextStyle" style)
           )
         )
        ) ; end cond Leader

        ;; ADDED by 3dwannab on 21/03/2019
        ;; ============================================================
        ((vl-position ObjName '("AcDbMline")) ; found a Multiline
         (set:Layer:Colour:LType:LWeight:Trans obj)
         (set-current "CMLSTYLE" (get-property obj 'StyleName))
         (command "._MLINE")
        ) ; end cond MLINE

        ;; ADDED by 3dwannab on 2024.07.23
        ;; ============================================================
        ((vl-position ObjName '("AcDbHatch")) ; found a Multiline
         (set:Layer:Colour:LType:LWeight:Trans obj)

         (princ "\nDraw your hatch boundary with a polyline (Polyline deleted afterwards)\n")
         (command-s "_.PLINE")

         (while (< 0 (getvar (quote cmdactive))) 
           (command "\\")
         )

         (setq enLast (entlast))

         ;; https://forums.augi.com/showthread.php?162033-Select-the-last-N-entities-created-in-a-lisp-routine&p=1294770&viewfull=1#post1294770
         ;; Snippet of code to check entities created by the program and nothing else.
         (setq ss (ssadd))
         (if (setq en (entnext enLast))  ;; Check if there's a new entity created since the last one
           (while en  ;; Step through all new entities
             (ssadd en ss) ;; Add it to the selection set
             (setq en (entnext en)) ;; Get the next entity
           )
         )

         (if enLast (setq vertsLen (/ (length (vlax-get (vlax-ename->vla-object enLast) 'Coordinates)) 2)))

         (if 
           (and 
             enLast
             (> vertsLen 2) ;; Check if there's more than 2 vertices
           )

           (progn 

             ;; Auto closes the polyline if it's not already
             (if (not (vlax-curve-isclosed enLast)) 
               (vla-put-closed (vlax-ename->vla-object enLast) :vlax-true)
             )

             (command "_.-hatch" "_P" "_S" "_LA" "." "_advanced" "_associativity" "_yes" "" "_select" enLast "" "")
             (setq enLastHatch (entlast))
             (command "_.matchprop" ent enLastHatch "")
             (command "erase" enLast "")
           )
         )
        ) ; end cond HATCH

        ((vl-position ObjName '("AcDbSpline")) ; found a Multiline
         (set:Layer:Colour:LType:LWeight:Trans obj)
         (command "._SPLINE")
        ) ; end cond SPLINE

        ((vl-position ObjName '("AcDbArc")) ; found a Multiline
         (set:Layer:Colour:LType:LWeight:Trans obj)
         (command "._ARC")
        ) ; end cond ARC

        ((vl-position ObjName '("AcDbLine")) ; found a Line
         (set:Layer:Colour:LType:LWeight:Trans obj)
         (command "._LINE")
         ;  (command "._PLINE")
         ;  (c:lg) ;; Line gap lisp
        ) ; end cond Line

        ((vl-position ObjName '("AcDbPolyline")) ; found a Polyline

         (setq plWidthOrg (getvar 'PLINEWID))
         (setq plWidth (get-property obj 'ConstantWidth))
         (setvar 'plinewid plWidth)
         (set:Layer:Colour:LType:LWeight:Trans obj)

         (command "._PLINE")
         ;  (c:lg) ;; Line gap lisp

         ;; This waits while the Polyline command is finished and then sets the PLINEWID variable back to the original
         (while (= 1 (logand 1 (getvar 'cmdactive))) (vl-cmdf "\\"))

         ;  (setvar "PLINEWID" plWidthOrg)
        ) ; end cond AcDbPolyline

        ((vl-position ObjName '("AcDbWipeout")) ; found a Wipeout
         (set:Layer:Colour:LType:LWeight:Trans obj)
         (command "._WIPEOUT")
        ) ; end cond AcDbWipeout

        ;; ===========================================================
        ((or (wcmatch ObjName "*Text*")  ; gets Rtext as well "AcDbMText"
             (= ObjName "AcDbAttributeDefinition")
         )
         (set:Layer:Colour:LType:LWeight:Trans obj)
         (set-current "TextStyle" (get-property obj 'StyleName))
         (set-current "TextSize" (get-property obj 'height))
         ;;  ----  Found no vlax method for this yet  -----
         ;;  Look for leader attached to set dim Style Current
         (setq idx (length (setq entbl (entget ent))))
         (while (> (setq idx (1- idx)) -1) 
           (setq ent (nth idx entbl))
           (cond 
             ((and (= (car ent) 330)  ; pointer to leader
                   (setq elst (entget (cdr ent))) ; valid ent ??
                   (wcmatch (cdr (assoc 0 elst)) "*LEADER")
              )
              (set-current "DimStyle" (cdr (assoc 3 elst))) ;  Set Dim Style Current
              (setq idx 0) ; 0 = exit loop
             ) ; cond
           ) ; cond stmt
         ) ; while
        ) ; end cond Text

        ;; =============================================================
        ((wcmatch ObjName "*Dimension*")
         (set:Layer:Colour:LType:LWeight:Trans obj)
         (set-current "DimStyle" (get-property obj 'StyleName))
        ) ; end cond Dimension

        ;; =============================================================
        (t ; catch any other object
         (set:Layer:Colour:LType:LWeight:Trans obj)
        ) ; end cond (T)
      ) ; end Cond stmt

      ;;  set current LineType & LineWeight if variables were set (03.02.14)
      (and LWeight (setvar "ceLWeight" LWeight))
      (setvar "ceColor" 
              (cond 
                ((or (null LColor) (= LColor 256)) "ByLayer")
                ((= LColor 0) "ByBlock")
                ((= (type LColor) 'str) LColor)
                (t (itoa LColor))
              )
      )

      ; (command "undo" "end")
      (setvar "CMDECHO" usercmd)
    ) ; end progn
  ) ; endif

  (princ)
) ;End of Defun
(prompt "\nACAD Settings Changer Loaded, Type TDS to run\n")
(princ)

;;(c:tds) ;; Unblock for testing

 

Edited July 23 by 3dwannab

[marko_ribar]

Ha, ha, ha...

I didn't paid any euro's... I just founded it on www by surfing, briefly installed it, evaluated software and come to conclusion that I don't need it for my work... Like I already pointed - looked from *.chm file - they already used Hatch Making algorithm from Lanny Schiele to make *.pat files... Link : https://www.cadtutor.net/forum/topic/70417-make-pat-files/?do=findComment&comment=644565

And, BTW. I or anyone must be total looser if I'd pay in advance to get something I am not satisfied enough...

[3dwannab]

21 minutes ago, marko_ribar said:

And, BTW. I or anyone must be total looser if I'd pay in advance to get something I am not satisfied enough...

Ha, I guess, what version of ACAD are you running.