Leaderboard

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

This was done about 1985 plus a couple of others. Its part of a bundle of programs will find an index page have a paper copy not a electronic will scan. Have the kerb 1/4 point setout somwhere, but and a big BUT it is not relevant having worked as a setout surveyor on roads you set out the 1/4 points based on a start and end peg that is offset from the back of the kerb so different values. Now use a GPS have smart offset calcs built in.

Something I have been playing with. All welcome to add comment good or bad, a work in progress. Needs arc to be added. Probably change cords to use an ent and assoc 10. ; Pline properties use as a library function ; By Alan H july 2020 (defun cords (obj / co-ords xy ) (setq coordsxy '()) (setq co-ords (vlax-get obj 'Coordinates)) (setq numb (/ (length co-ords) 2)) (setq I 0) (repeat numb (setq xy (list (nth (+ I 1) co-ords)(nth I co-ords) )) (setq coordsxy (cons xy coordsxy)) (setq I (+ I 2)) ) ) (defun AH:chkcwccw (obj / objplnew area1 area2 minpoint maxpoint oldsnap) (setq oldsnap (getvar 'osmode)) (setvar 'osmode 0) (vla-GetBoundingBox obj 'minpoint 'maxpoint) (setq pointmin (vlax-safearray->list minpoint)) (setq pointmax (vlax-safearray->list maxpoint)) (setq dist (/ (distance pointmin pointmax) 20.0)) (vla-offset obj dist) (setq objplnew (vlax-ename->vla-object (entlast))) (setq area1 (vlax-get objplnew 'Area)) (vla-delete objplnew) (vla-offset obj (- dist)) (setq objplnew (vlax-ename->vla-object (entlast))) (setq area2 (vlax-get objplnew 'Area)) (vla-delete objplnew) (if (> area1 area2) (setq cw "Clockwise") (setq cw "Anti") ) (setvar 'osmode oldsnap) ) ; thanks to Lee-mac for this defun ; www.lee-mac.com ; 44 is comma (defun _csv->lst ( str / pos ) (if (setq pos (vl-string-position 44 str)) (cons (substr str 1 pos) (_csv->lst (substr str (+ pos 2)))) (list str) ) ) (defun plprops (obj txt / lst) (setq lst (_csv->lst txt)) (foreach val lst (cond ((= (strcase val) "LAY") (setq lay (vla-get-layer obj))) ((= (strcase val) "AREA")(setq area (vla-get-area obj))) ((= (strcase val) "START")(setq start (vlax-curve-getstartpoint obj))) ((= (strcase val) "END" (strcase txt))(setq end (vlax-curve-getendpoint obj))) ((= (strcase val) "LEN" (strcase txt))(setq len (vlax-get obj 'Length))) ((= (strcase val) "CW" (strcase txt))(AH:chkcwccw obj)) ((= (strcase val) "CORDS" (strcase txt))(CORDS obj)) ) ) ) (defun lineprops (obj txt / lst) (setq lst (_csv->lst txt)) (foreach val lst (cond ((= (strcase val) "LAY") (setq lay (vlax-get obj 'layer))) ((= (strcase val) "START")(setq start (vlax-get obj 'startpoint))) ((= (strcase val) "END" (strcase txt))(setq end (vlax-get obj 'endpoint))) ((= (strcase val) "LEN" (strcase txt))(setq len (vlax-get obj 'Length))) ) ) ) (defun circprops (obj txt / lst) (setq lst (_csv->lst txt)) (foreach val lst (cond ((= (strcase val) "LAY") (setq lay (vlax-get obj 'layer))) ((= (strcase val) "LEN" (strcase txt))(setq len (vlax-get obj 'Circumference))) ((= (strcase val) "RAD" (strcase txt))(setq rad (vla-get-radius obj))) ((= (strcase val) "CEN" (strcase txt))(setq cen (vlax-get obj 'Center))) ((= (strcase val) "AREA" (strcase txt))(setq area (vlax-get obj 'area))) ) ) ) ; starts here (setq ent (vlax-ename->vla-object (car (entsel "Pick Object ")))) ; do a check for object type then use a cond ; pick an example below ; many examples copy to command line for testing mix and match ; (plprops ent "LAY")(princ lay) ; (plprops ent "END")(princ end) ; (plprops ent "START")(princ start) ; (plprops ent "END,START")(princ end)(princ start) ; (plprops ent "AREA,LAY,END,START")(princ area)(princ lay)(princ end)(princ start) ; (plprops ent "START,AREA,LAY,CW")(princ start)(princ area)(princ cw) ; (plprops ent "start,END,CORDS,cw")(princ start)(princ end)(princ coordsxy)(princ cw) ; (plprops ent "CW")(princ cw) ; (plprops ent "AREA")(princ area) ; (plprops ent "CORDS")(princ coordsxy) ; (lineprops ent "len")(princ len) ; (lineprops ent "len,lay")(princ len)(princ lay) ; (lineprops ent "lay,end,start,len")(princ len)(princ lay)(princ start)(princ end) ; (circprops ent "lay,rad,area,cen")(princ lay)(princ rad)(princ area)(princ cen) ; (circprops ent "lay,rad")

A couple of old fashioned DOS commands Copy File1+file2+File3 file4 Dir d:\cadtemp\*.dwg /b /s > dirlst.txt makes a list of all your dwgs including sub directories. For me I use Word to make scripts using Replace ^p which is end of line so can do like ^pOpen which adds open to start of every line, like wise save^p dont forget spaces in replace.

22/7 is only an approximation for PI.

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

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

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)