Jump to content

Move Hatching to specified layer

gsteel

By gsteel
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

gsteel Apprentice

gsteel

Posted
Posted

Hi I hope someone can help me here.

I have a drawing with 300 or so blocks most of which have some sort of hatching.

 

Does someone know of or could someone write a lisp routine that would select all hatches (including within the blocks) and move the to a specified layer?

 

Moving any associated polyline would probably be the right thing to do too

 

It sounds fairly simple task but I am not very experienced in Autocad. I have been trying to learn how to a write lisp routine but admittedly I am completely hopeless. I have been searching forums and the closest lisp I have found is this one http://forums.cadalyst.com/showthread.php?t=5597 but seems to only move hatches with colour set to bylayer.

 

I would really appreciate any help someone could give me here.

Thanks

  • Like 1
VVA Rising Star

VVA

Posted
Posted

Try it.

Made small change to Hatchdel command

(vl-load-com)
(defun C:HatchDel ()(work-whith-all-hatch nil))
(defun C:Hatch2Lay ()
 ;;; Hatch to Layer
 ;;; http://www.cadtutor.net/forum/showthread.php?87471-Move-Hatching-to-specified-layer
 (work-whith-all-hatch
   "NewLayerForHatch"   ;_  type  layer name for hatch
   )
 (alert "Done!")(princ)
 )
(defun work-whith-all-hatch ( what  / adoc *error*)
 ;;; what - nil - delete
 ;;;      - string - layer to move
 (defun *error* (msg)
   (setvar "MODEMACRO" "")
   (princ msg)
   (vla-regen aDOC acactiveviewport)
   (bg:progress-clear)
   (bg:layer-status-restore)
   (princ)
 ) ;_ end of defun
 (defun _loc-delete-items ()
   (if	(= (vla-get-IsXref Blk) :vlax-false)
     (progn
(setq count 0)
(if (> (vla-get-count Blk) 100)
  (bg:progress-init
    (strcat (vla-get-name Blk) " :")
    (vla-get-count Blk)
  ) ;_ end of bg:progress-init
  (progn
    (setvar "MODEMACRO" (vla-get-name Blk))
  ) ;_ end of progn
) ;_ end of if
(vlax-for Obj Blk
  (if (= (vla-get-ObjectName Obj) "AcDbHatch")
           (if (and what (eq (type what) 'STR))
             (vl-catch-all-apply 'vla-put-Layer (list Obj what))
             (vl-catch-all-apply 'vla-delete (list Obj))
             )
  ) ;_ end of if
) ;_ end of vlax-for
(bg:progress-clear)
     ) ;_ end of progn
   ) ;_ end of if
 ) ;_ end of defun
 (setq	aDOC (vla-get-activedocument (vlax-get-acad-object)))
 (if (and (eq (type what) 'STR)
          (not(tblobjname "LAYER" what))
          )
   (vla-add (vla-get-Layers aDOC) what)
   )
 (bg:layer-status-save)
 (vlax-for Blk (vla-get-Blocks aDOC)
(_loc-delete-items)
   )
 (bg:layer-status-restore)
   (vla-regen aDOC acActiveViewport)
 (princ)
) ;_ end of defun
(defun bg:layer-status-restore ()
   (foreach item *BG_LAYER_LST*
     (if (not (vlax-erased-p (car item)))
       (vl-catch-all-apply
         '(lambda ()
            (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
            (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
            ) ;_ end of lambda
         ) ;_ end of vl-catch-all-apply
       ) ;_ end of if
     ) ;_ end of foreach
   (setq *BG_LAYER_LST* nil)
   ) ;_ end of defun

 (defun bg:layer-status-save ()
   (setq *BG_LAYER_LST* nil)
   (vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
     (setq *BG_LAYER_LST* (cons (list item
                                 (cons "freeze" (vla-get-freeze item))
                                 (cons "lock" (vla-get-lock item))
                                 ) ;_ end of cons
                           *BG_LAYER_LST*
                           ) ;_ end of cons
           ) ;_ end of setq
     (vla-put-lock item :vlax-false)
     (if (= (vla-get-freeze item) :vlax-true)
     (vl-catch-all-apply '(lambda () (vla-put-freeze item :vlax-false))))
     ) ;_ end of vlax-for
   ) ;_ end of defun
(defun bg:progress-init (msg maxlen)
 ;;; msg - ñîîáùåíèå èëè ïóñòàÿ ñòðîêà
 ;;; maxlen - ìàêñèìàëüíîå êîëè÷åñòâî
 (setq *BG:PROGRESS:OM* (getvar "MODEMACRO"))
 (setq *BG:PROGRESS:MSG* (vl-princ-to-string msg))
 (setq *BG:PROGRESS:MAXLEN* maxlen)
 (setq *BG:PROGRESS:LPS* '-1)(princ)
 )
(defun bg:progress ( currvalue / persent str1 count)
 (if *BG:PROGRESS:MAXLEN*
   (progn
 (setq persent (fix (/ currvalue 0.01 *BG:PROGRESS:MAXLEN*)))
 ;;;Êàæäûå 5 %
 (setq count (fix(* persent 0.2)))
 (setq str1 "")
 (if (/= count *BG:PROGRESS:LPS*)
   (progn
     ;;(setq str1 "")
     (repeat persent (setq str1 (strcat str1 "|")))
     )
   )
      ;;; currvalue - òåêóùåå çíà÷åíèå
     (setvar "MODEMACRO"
             (strcat (vl-princ-to-string *BG:PROGRESS:MSG*)
                     " "
                     (itoa persent)
                     " % "
                     str1
                     )
             )
     (setq *BG:PROGRESS:LPS* persent)
 )
   )
 )
    
(defun bg:progress-clear ()
 (setq *BG:PROGRESS:MSG* nil)
 (setq *BG:PROGRESS:MAXLEN* nil)
 (setq *BG:PROGRESS:LPS* nil)
 (setvar "MODEMACRO" (vl-princ-to-string *BG:PROGRESS:OM*))
 ;;;(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
 (princ)
 )
(princ "\nType HatchDel or Hatch2Lay in command line")(princ)

gsteel Apprentice

gsteel

Posted
  • Author
Posted

man that's awesome........thanks

 

If it's not too cheeky to ask if a few modifications are possible......

Is it possible to move any associated polylines with the hatches

Is it possible for it to work on selected objects only?

Is there a way to specify the layer without editing the .lsp file?

 

If not I can work round it but if it's straight forward :)

 

Big thanks again this is a real time saver.

VVA Rising Star

VVA

Posted
Posted (edited)

New Version

(vl-load-com)
(defun C:HatchDelALL () (work-whith-all-hatch nil))
(defun C:HatchDelSEL ()
 (work-whith-selected-hatch
   nil
   (msg-yes-no "Select" "Delete associative polylines?")
   )
 )
(defun C:Hatch2LayALL (/ lay)
;;; ALL Hatch to Layer
;;; http://www.cadtutor.net/forum/showthread.php?87471-Move-Hatching-to-specified-layer
 (if
   (setq lay (mydcl "Select Layers"
                    (vl-remove-if-not
                      'snvalid
                      (acad_strlsort (tablelist "Layer"))
                    ) ;_ end of vl-remove-if-not
             ) ;_ end of mydcl
   ) ;_ end of setq
    (progn
      (work-whith-all-hatch (car lay))
      (princ "\nDone!")
      (princ)
    ) ;_ end of progn
 ) ;_ end of if
) ;_ end of defun
(defun C:Hatch2LaySEL (/ lay)
;;; Selected Hatch to Layer
;;; http://www.cadtutor.net/forum/showthread.php?87471-Move-Hatching-to-specified-layer
 (if
   (setq lay (mydcl "Select Layers"
                    (vl-remove-if-not
                      'snvalid
                      (acad_strlsort (tablelist "Layer"))
                    ) ;_ end of vl-remove-if-not
             ) ;_ end of mydcl
   ) ;_ end of setq
    (progn
      (work-whith-selected-hatch
        (car lay)
        (msg-yes-no "Select" "Move to layer associative polylines?")
        )
      (princ "\nDone!")
      (princ)
    ) ;_ end of progn
 ) ;_ end of if
) ;_ end of defun

(defun work-whith-all-hatch
      (what / adoc *error* poly _loc-delete-or-move-items)
;;; what - nil - delete
;;;      - string - layer to move
 (defun *error* (msg)
   (setvar "MODEMACRO" "")
   (princ msg)
   (vla-regen aDOC acactiveviewport)
   (bg:progress-clear)
   (bg:layer-status-restore)
   (vla-endundomark aDOC)
   (princ)
 ) ;_ end of defun
 (defun _loc-delete-or-move-items (Blk)
   (if (= (vla-get-isxref Blk) :vlax-false)
     (progn
       (if (> (vla-get-count Blk) 100)
         (bg:progress-init
           (strcat (vla-get-name Blk) " :")
           (vla-get-count Blk)
         ) ;_ end of bg:progress-init
         (progn
           (setvar "MODEMACRO" (vla-get-name Blk))
         ) ;_ end of progn
       ) ;_ end of if
       (vlax-for Obj Blk
         (if (= (vla-get-objectname Obj) "AcDbHatch")
           (progn
             (if (and what (eq (type what) 'STR))
               (vl-catch-all-apply 'vla-put-layer (list Obj what))
               (vl-catch-all-apply 'vla-delete (list Obj))
             ) ;_ end of if
           ) ;_ end of progn
         ) ;_ end of if
       ) ;_ end of vlax-for
       (bg:progress-clear)
     ) ;_ end of progn
   ) ;_ end of if
 ) ;_ end of defun
 (setq aDOC (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark aDOC)
 (if (and (eq (type what) 'STR)
          (not (tblobjname "LAYER" what))
     ) ;_ end of and
   (vla-add (vla-get-layers aDOC) what)
 ) ;_ end of if
 (bg:layer-status-save)
 (vlax-for Blk (vla-get-blocks aDOC)
   (_loc-delete-or-move-items Blk)
 ) ;_ end of vlax-for
 (bg:layer-status-restore)
 (vla-endundomark aDOC)
 (vla-regen aDOC acactiveviewport)
 (princ)
) ;_ end of defun
(defun work-whith-selected-hatch
      (what assocpoly / adoc *error* ss lst poly _loc-delete-items)
;;; what - nil - delete
;;;      - string - layer to move
;;; assocpoly - t - move associated poly
;;;            nil - not
 (defun *error* (msg)
   (setvar "MODEMACRO" "")
   (princ msg)
   (vla-regen aDOC acactiveviewport)
   (bg:progress-clear)
   (bg:layer-status-restore)
   (vla-endundomark aDOC)
   (princ)
 ) ;_ end of defun
 (defun _loc-delete-items (Blk)
   (if (= (vla-get-isxref Blk) :vlax-false)
     (progn
       (setq count 0)
       (if (> (vla-get-count Blk) 100)
         (bg:progress-init
           (strcat (vla-get-name Blk) " :")
           (vla-get-count Blk)
         ) ;_ end of bg:progress-init
         (progn
           (setvar "MODEMACRO" (vla-get-name Blk))
         ) ;_ end of progn
       ) ;_ end of if
       (vlax-for Obj Blk
         (if (= (vla-get-objectname Obj) "AcDbHatch")
           (progn
;;; >>>>> Associated entities begin
             (if assocpoly
             (setq poly
                        (mapcar 'cdr
                                (vl-remove-if-not
                                  '(lambda (x) (= (car x) 330))
                                  (entget (vlax-vla-object->ename Obj))
                                ) ;_ end of vl-remove-if-not
                        ) ;_ end of mapcar
                   poly (vl-remove-if-not
                          '(lambda (x)
                             (wcmatch (cdr (assoc 0 (entget x)))
                                      "*LINE,CIRCLE,ELLIPSE"
                             ) ;_ end of wcmatch
                           ) ;_ end of lambda
                          poly
                        ) ;_ end of vl-remove-if-not
             ) ;_ end of setq
             (setq poly nil)  
               )
;;; <<<<<< Associated entities end
             (if (and what (eq (type what) 'STR))
               (mapcar
                 '(lambda (x)
                    (vl-catch-all-apply 'vla-put-layer (list x what))
                  ) ;_ end of lambda
                 (cons Obj (if poly (mapcar 'vlax-ename->vla-object poly) nil))
               ) ;_ end of mapcar
               (mapcar '(lambda (x)
                          (vl-catch-all-apply 'vla-delete (list x))
                        ) ;_ end of lambda
                       (cons Obj (if poly (mapcar 'vlax-ename->vla-object poly) nil))
               ) ;_ end of mapcar
             ) ;_ end of if
           ) ;_ end of progn
         ) ;_ end of if
       ) ;_ end of vlax-for
       (bg:progress-clear)
     ) ;_ end of progn
   ) ;_ end of if
 ) ;_ end of defun
 (setq aDOC (vla-get-activedocument (vlax-get-acad-object)))
 (vla-startundomark aDOC)
 (if (and (eq (type what) 'STR)
          (not (tblobjname "LAYER" what))
     ) ;_ end of and
   (vla-add (vla-get-layers aDOC) what)
 ) ;_ end of if
 (if (and
       (setq ss (ssget "_:L" '((0 . "HATCH,INSERT"))))
       (setq lst (mapcar 'vlax-ename->vla-object (pickset-to-list ss)))
     ) ;_ end of and
   (progn
     (bg:layer-status-save)
     (foreach obj lst
       (cond
         ((= (vla-get-objectname Obj) "AcDbHatch")
         (if  assocpoly
          (setq poly
                     (mapcar 'cdr
                             (vl-remove-if-not
                               '(lambda (x) (= (car x) 330))
                               (entget (vlax-vla-object->ename Obj))
                             ) ;_ end of vl-remove-if-not
                     ) ;_ end of mapcar
                poly (vl-remove-if-not
                       '(lambda (x)
                          (wcmatch (cdr (assoc 0 (entget x)))
                                   "*LINE,CIRCLE,ELLIPSE"
                          ) ;_ end of wcmatch
                        ) ;_ end of lambda
                       poly
                     ) ;_ end of vl-remove-if-not
          ) ;_ end of setq
          (setq poly nil)
          )
          (if (and what (eq (type what) 'STR))
            (mapcar '(lambda (x)
                       (vl-catch-all-apply 'vla-put-layer (list x what))
                     ) ;_ end of lambda
                     (cons Obj (if poly (mapcar 'vlax-ename->vla-object poly) nil))
            ) ;_ end of mapcar
            (mapcar
              '(lambda (x) (vl-catch-all-apply 'vla-delete (list x)))
              (cons Obj (mapcar 'vlax-ename->vla-object poly))
            ) ;_ end of mapcar
          )
         )
         ((and
            (= (vla-get-objectname Obj) "AcDbBlockReference")
            (= (vla-get-isxref
                 (setq Blk (vla-item (vla-get-blocks aDOC)
                                     (vla-get-effectivename Obj)
                           ) ;_ end of vla-item
                 ) ;_ end of setq
               ) ;_ end of vla-get-IsXref
               :vlax-false
            ) ;_ end of =
          ) ;_ end of and
          (_loc-delete-items Blk)
         )
         (t nil)
       ) ;_ end of cond
     ) ;_ end of foreach
     (bg:layer-status-restore)
   ) ;_ end of progn
 ) ;_ end of if
 (vla-endundomark aDOC)
 (vla-regen aDOC acactiveviewport)
 (princ)
) ;_ end of defun
(defun bg:layer-status-restore ()
 (foreach item *BG_LAYER_LST*
   (if (not (vlax-erased-p (car item)))
     (vl-catch-all-apply
       '(lambda ()
          (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
          (vla-put-freeze
            (car item)
            (cdr (assoc "freeze" (cdr item)))
          ) ;_ end of vla-put-freeze
        ) ;_ end of lambda
     ) ;_ end of vl-catch-all-apply
   ) ;_ end of if
 ) ;_ end of foreach
 (setq *BG_LAYER_LST* nil)
) ;_ end of defun

(defun bg:layer-status-save ()
 (setq *BG_LAYER_LST* nil)
 (vlax-for item (vla-get-layers
                  (vla-get-activedocument (vlax-get-acad-object))
                ) ;_ end of vla-get-layers
   (setq *BG_LAYER_LST*
          (cons (list item
                      (cons "freeze" (vla-get-freeze item))
                      (cons "lock" (vla-get-lock item))
                ) ;_ end of cons
                *BG_LAYER_LST*
          ) ;_ end of cons
   ) ;_ end of setq
   (vla-put-lock item :vlax-false)
   (if (= (vla-get-freeze item) :vlax-true)
     (vl-catch-all-apply
       '(lambda () (vla-put-freeze item :vlax-false))
     ) ;_ end of vl-catch-all-apply
   ) ;_ end of if
 ) ;_ end of vlax-for
) ;_ end of defun
(defun bg:progress-init (msg maxlen)
;;; msg - niiauaiea eee ionoay no?iea
;;; maxlen - iaeneiaeuiia eiee?anoai
 (setq *BG:PROGRESS:OM* (getvar "MODEMACRO"))
 (setq *BG:PROGRESS:MSG* (vl-princ-to-string msg))
 (setq *BG:PROGRESS:MAXLEN* maxlen)
 (setq *BG:PROGRESS:LPS* '-1)
 (princ)
) ;_ end of defun
(defun bg:progress (currvalue / persent str1 count)
 (if *BG:PROGRESS:MAXLEN*
   (progn
     (setq persent (fix (/ currvalue 0.01 *BG:PROGRESS:MAXLEN*)))
;;;Ea?aua 5 %
     (setq count (fix (* persent 0.2)))
     (setq str1 "")
     (if (/= count *BG:PROGRESS:LPS*)
       (progn
         ;;(setq str1 "")
         (repeat persent (setq str1 (strcat str1 "|")))
       ) ;_ end of progn
     ) ;_ end of if
;;; currvalue - oaeouaa cia?aiea
     (setvar "MODEMACRO"
             (strcat (vl-princ-to-string *BG:PROGRESS:MSG*)
                     " "
                     (itoa persent)
                     " % "
                     str1
             ) ;_ end of strcat
     ) ;_ end of setvar
     (setq *BG:PROGRESS:LPS* persent)
   ) ;_ end of progn
 ) ;_ end of if
) ;_ end of defun

(defun bg:progress-clear ()
 (setq *BG:PROGRESS:MSG* nil)
 (setq *BG:PROGRESS:MAXLEN* nil)
 (setq *BG:PROGRESS:LPS* nil)
 (setvar "MODEMACRO" (vl-princ-to-string *BG:PROGRESS:OM*))
;;;(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
 (princ)
) ;_ end of defun
(defun mydcl (zagl info-list / fl ret dcl_id msg)
 (vl-load-com)
 (if (null zagl)
   (setq zagl "Select")
 ) ;_ end if
 (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
 (setq ret (open fl "w"))
 (mapcar '(lambda (x) (write-line x ret))
         (list "mip_msg : dialog { "
               (strcat "label=\"" zagl "\";")
               " :list_box {"
               "alignment=top ;"
               "multiple_select = true ;"
               "width=31 ;"
               (if (> (length info-list) 26)
                 "height= 26 ;"
                 (strcat "height= " (itoa (+ 3 (length info-list))) ";")
               ) ;_ end of if
               "is_tab_stop = false ;"
               "key = \"info\";}"
               "ok_cancel;}"
         ) ;_ end of list
 ) ;_ end of mapcar
 (setq ret (close ret))
 (if (and (null (minusp (setq dcl_id (load_dialog fl))))
          (new_dialog "mip_msg" dcl_id)
     ) ;_ end and
   (progn (start_list "info")
          (mapcar 'add_list info-list)
          (end_list)
          (set_tile "info" "0")
          (setq ret "0")
          (action_tile "info" "(setq ret $value)")
          (action_tile "cancel" "(done_dialog 0)")
          (action_tile "accept" " (done_dialog 1)")
          (if (zerop (start_dialog))
            (setq ret nil)
            (setq
              ret (mapcar (function (lambda (num) (nth num info-list)))
                          (read (strcat "(" ret ")"))
                  ) ;_ end mapcar
            ) ;_ end setq
          ) ;_ end if
          (unload_dialog dcl_id)
   ) ;_ end of progn
 ) ;_ end of if
 (vl-file-delete fl)
 ret
) ;_ end of defun
(defun tablelist (s / d r)
 (while (setq d (tblnext s (null d)))
   (setq r (cons (cdr (assoc 2 d)) r))
 ) ;_while
) ;_defun
(defun pickset-to-list (value / lst item)
 (repeat (setq item (sslength value)) ;_ end setq
   (setq lst (cons (ssname value (setq item (1- item))) lst))
 ) ;_ end repeat
 lst
) ;_ end of defun

(defun msg-yes-no ( title message / WScript ret)
(setq WScript (vlax-get-or-create-object "WScript.Shell"))
(setq ret (vlax-invoke-method WScript "Popup" message "0" title (+ 4 48)))
(if WScript (vlax-release-object WScript))
(= ret 6)  
)
(princ
 "\nType HatchDelALL, HatchDelSEL, Hatch2LayALL, Hatch2LaySel in command line"
) ;_ end of princ
(princ)

Edited by VVA
  • Thanks 1
gsteel Apprentice

gsteel

Posted
  • Author
Posted

You are amazing!!!!!! 'hatch2laysel' is just perfect.

 

Really I can't thank you enough. :notworthy:

gsteel Apprentice

gsteel

Posted
  • Author
Posted

Now that I am using it in production I notice that some of the blocks have been constructed so that that the associated polyline is the main drawing line and some have hidden associated polylines.

 

Is there any way to add an option to move the associated polylines or not?

gsteel Apprentice

gsteel

Posted
  • Author
Posted

Really sorry for the re-post.

 

The necessity to move the associated polyline really seem to be by exception so just removing the function for moving the associated poly line would be fine. I have had a look through and have no idea how I would do it myself.

VVA Rising Star

VVA

Posted
Posted

You can define your command + #4

(defun C:HA2LSEL (/ lay)
;;; Selected Hatch + Associated polyline to Layer
 (if
   (setq lay (mydcl "Select Layers"
                    (vl-remove-if-not
                      'snvalid
                      (acad_strlsort (tablelist "Layer"))
                    ) ;_ end of vl-remove-if-not
             ) ;_ end of mydcl
   ) ;_ end of setq
    (progn
      (work-whith-selected-hatch
        (car lay)
     [color="red"]   t ;_ t or nil t - move associated polyline[/color]
        )
      (princ "\nDone!")
      (princ)
    ) ;_ end of progn
 ) ;_ end of if
) ;_ end of defun
(defun C:H2LSEL (/ lay)
;;; Selected Hatch to Layer
 (if
   (setq lay (mydcl "Select Layers"
                    (vl-remove-if-not
                      'snvalid
                      (acad_strlsort (tablelist "Layer"))
                    ) ;_ end of vl-remove-if-not
             ) ;_ end of mydcl
   ) ;_ end of setq
    (progn
      (work-whith-selected-hatch
        (car lay)
       [color="red"] nil ;_ t or nil t - move associated polyline[/color]
        )
      (princ "\nDone!")
      (princ)
    ) ;_ end of progn
 ) ;_ end of if
) ;_ end of defun

  • Thanks 1
gsteel Apprentice

gsteel

Posted
  • Author
Posted

Many thanks again......took me a wee while to work out what to do but got there.

 

A free script and a bit of learning! Lovin' it :D

  • Like 1
  • 6 years later...
cadsnapamy Newbie

cadsnapamy

Posted
Posted

6 years later... 
Thank you so much for sharing this! Hatch2LayAll worked a charm for me.
I too managed to work out what to do with the additional scripts, and I feel better for having to put that effort in. #1337h4x0r :D

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