Hatching By Lisp

[sam_safinia]

I have this block that I want to hatch it internally using lisp routine for different hatch type, pattern,scale,etc. I wrote a lisp that is doing my job but how can I resole these two issues:

1) As I want to have another option to hatch my block externally, how can hatch via this lisp in a way to get selected size (from dynamic block attribute property) and add extra 25mm and hatch it. For instance, for the size of 100mm , internal hatch boundary length will be 150mm in total.

2) Is there any way to associate hatch angle with object rotation? I mean if I select rotated object and insert hatch patter I want hatch angle follow object orientation.

[Kent1Cooper]

---

@s_plant wrote:

.... 

2) Is there any way to associate hatch angle with object rotation? I mean if I select rotated object and insert hatch patter I want hatch angle follow object orientation.

---

If it's always a Block, and its definition has things orthogonally oriented when at 0 rotation, then you can first set the HPANG System Variable to match the Block's rotation [= (cdr (assoc 50 entitydatalist)) or the Rotation VLA Property].

For other kinds of objects with some kind of linearity, it is possible to calculate the direction of slope at the selection point, and set that into the HPANG System Variable.  You can get some code to start with from this, which does other things you will probably not want included, but can be adjusted appropriately to use the calculated direction as you want it to.

[sam_safinia]

...

2)

one step ahead...

I managed to define two separate routine which they get "Block Rotation" as HROT and "Dynamic Block Orientation Value" as HORI to align HPANG with block and insert the hatch.

But it was not that simple that I thought because the proper hatch alignment will be combination of both of them. In below illustration these misalignment issue of different scenario can be seen. Then I came up with this golden formula to get right HPANG for hatching :

HPANG VALUE : (ROTATION ANGLE - 360 ) - ORIENTATION ANGLE
HPANG VALUE in lisp : (rotang- 360 ) - oriang

HROT:

Spoiler

(defun C:HROT ( / ss count e en rotang)
(setq ss (ssget '((0 . "INSERT"))))
(initget (+ 1))
(terpri)
(setq count 0)
(while (< count (sslength ss))
(setq e (entget(ssname ss count)))
(setq en (cdar e))
(setq rotang (cdr(assoc 50 e)))
(setq rotang (/ (* rotang 180.0)pi))
(command "hatch" "P" "ANSI31" "200" rotang "S" pause "" "")
(setq count (+ count 1))
(princ)
)
(setq ss nil)
)

HORI:

Spoiler

(defun dynval ( blk prop )
(setq prop (strcase prop))
(vl-some '(lambda ( x ) (if (= prop (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
(vlax-invoke blk 'getdynamicblockproperties)
)
)
(defun c:HORI ( / ee oriang )
(if (and (setq ee (car (entsel "\nSelect block: ")))
(= "INSERT" (cdr (assoc 0 (entget ee))))
)
(setq oriang (dynval (vlax-ename->vla-object ee) "Orientation")))
(command "hatch" "P" "ANSI31" "200" (angtos oriang) "S" pause "" "")
)
(princ)
)

In summary, how can I combine these two lisp in a math formula to get HPANG right?!

Also the block need to select twice to hatch it and I could not resolve this issue.

I appreciated any help folks 🙂

[sam_safinia]

and for my first question, I found these routine which give good guide lines. How can I comine them?

My plan for outline hatching is when select a block the routine will:

a) draw outside boundry of block (in background)

b) offset drawn polyline by 25 (in background)

c) insert hatch inside offset polyline and delete polyline (in background)

here is lisp and sources for "a" and "c" but I cannot figure out how to deal with step "b"??

"a") draw/extract outside boundry of block

Spoiler

;;; ! *********************************************************
;;; ! lib:IsPtInView *
;;; ! *********************************************************

;; ECO """"
(defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc)
(setq pt (trans pt 0 1))
(setq VCTR (getvar "VIEWCTR")
Y_Len (getvar "VIEWSIZE")
SSZ (getvar "SCREENSIZE")
X_Pix (car SSZ)
Y_Pix (cadr SSZ)
X_Len (* (/ X_Pix Y_Pix) Y_Len)
Lc (polar VCTR (dtr 180.0) (* 0.5 X_Len))
Uc (polar Lc 0.0 X_Len)
Lc (polar Lc (dtr 270.0) (* 0.5 Y_Len))
Uc (polar Uc (dtr 90.0) (* 0.5 Y_Len))
)
(if (and (> (car pt) (car Lc))
(< (car pt) (car Uc))
(> (cadr pt) (cadr Lc))
(< (cadr pt) (cadr Uc))
)
T
nil
)
)
(defun DTR (a) (* pi (/ a 180.0)))
(defun RTD (a) (/ (* a 180.0) pi))
;; ! **********************************************************
;; ! lib:Zoom2Lst *
;; ! **********************************************************

(defun lib:Zoom2Lst (vlist / bl tr Lst OS)
(setq Lst (lib:pt_extents vlist)
bl (car Lst)
tr (cadr Lst)
)
(if (not (and (lib:IsPtInView bl) (lib:IsPtInView tr)))
(progn (setq OS (getvar "OSMODE"))
(setvar "OSMODE" 0)
(command "_.Zoom"
"_Window"
(trans bl 0 1)
(trans tr 0 1)
"_.Zoom"
"0.95x"
)
(setvar "OSMODE" OS)
T
)
NIL
)
)
;; ! ************************************************************
;; ! lib:pt_extents *
;; ! ************************************************************

(defun lib:pt_extents (vlist / tmp)
(setq tmp
(mapcar
'(lambda (x) (vl-remove-if 'null x))
(mapcar
'(lambda (what)
(mapcar '(lambda (x)
(nth what x)
)
vlist
)
)
'(0 1 2)
)
)
) ;_setq
(list
(mapcar
'(lambda (x)
(apply 'min x)
)
tmp
)
(mapcar '(lambda (x) (apply 'max x)) tmp)
)
) ;_defun
;http://www.autocad.ru/cgi-bin/f1/board.cgi?t=30724Ed
;External contour of objects
(defun C:ECO (/ *error* blk obj MinPt MaxPt hiden
pt pl unnamed_block isRus tmp_blk adoc
blks lays lay oname sel csp loc
sc ec ret DS osm
)
(defun *error* (msg)
(mapcar '(lambda (x)
(vla-put-Visible x :vlax-true)
)
hiden
)
(vla-endundomark adoc)
(if (and tmp_blk
(not
(vlax-erased-p tmp_blk)
)
(vlax-write-enabled-p tmp_blk)
)
(vla-Erase tmp_blk)
)
(if osm
(setvar "OSMODE" osm)
)
(foreach x loc (vla-put-lock x :vlax-true))
)
(vl-load-com)
(setvar "CMDECHO" 0)
(setq osm (getvar "OSMODE"))
(if
(zerop (getvar "WORLDUCS"))
(progn
(vl-cmdf "_.UCS" "")
(vl-cmdf "_.Plan" "")
)
)
(setq isRus
(= (getvar "SysCodePage") "ANSI_1251")
)
(setq adoc
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
blks (vla-get-blocks adoc)
lays
(vla-get-layers adoc)
)
(vla-startundomark adoc)
(if isRus
(princ "\nВыберите объекты для построения контура")
(princ "\nSelect objects for making a contour")
)
(if (setq sel (ssget))
(progn
(setq sel
(mapcar 'vlax-ename->vla-object
(vl-remove-if
'listp
(mapcar 'cadr (ssnamex sel))
)
)
)
(setq csp
(vla-objectidtoobject
adoc
(vla-get-ownerid (car sel))
)
)
(setq unnamed_block
(vla-add (vla-get-blocks adoc)
(vlax-3d-point '(0. 0. 0.))
"*U"
)
)
(foreach x sel
(setq oname
(strcase (vla-get-objectname x))
lay
(vla-item lays (vla-get-layer x))
)
(if (= (vla-get-lock lay) :vlax-true)
(progn
(vla-put-lock lay :vlax-false)
(setq loc (cons lay loc))
)
)
(cond
((member oname '("ACDBVIEWPORT" "ACDBATTRIBUTEDEFINITION"))
nil
)
((= oname "ACDBBLOCKREFERENCE")
(vla-InsertBlock
unnamed_block
(vla-get-insertionpoint x)
(vla-get-name x)
(vla-get-xscalefactor x)
(vla-get-yscalefactor x)
(vla-get-zscalefactor x)
(vla-get-rotation x)
)
(setq blk (cons x blk))
)
(t (setq obj (cons x obj)))
)
) ;_foreach
(setq lay
(vla-item lays (getvar "CLAYER"))
)
(if
(= (vla-get-lock lay) :vlax-true)
(progn (vla-put-lock lay :vlax-false)
(setq loc (cons lay loc))
)
)
(if obj
(progn
(vla-copyobjects
(vla-get-activedocument
(vlax-get-acad-object)
)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length obj)))
)
obj
)
)
unnamed_block
)
)
)
(setq obj (append obj blk))
(if obj
(progn
(setq tmp_blk (vla-insertblock
csp
(vlax-3d-point '(0. 0. 0.))
(vla-get-name unnamed_block)
1.0
1.0
1.0
0.0
)
)
(vla-GetBoundingBox tmp_blk 'MinPt 'MaxPt) ;_Границы блока
(setq MinPt (vlax-safearray->list MinPt)
MaxPt (vlax-safearray->list MaxPt)
DS (max (distance MinPt (list (car MinPt) (cadr MaxPt)))
(distance MinPt (list (car MaxPt) (cadr MinPt)))
)
DS (* 0.2 DS) ;1/5
DS (max DS 10)
MinPt (mapcar '- MinPt (list DS DS))
MaxPt (mapcar '+ MaxPt (list DS DS))
)
(lib:Zoom2Lst (list MinPt MaxPt))
(setq sset (ssget "_C" MinPt MaxPt))
(if sset
(progn
(setvar "OSMODE" 0)
(setq hiden (mapcar 'vlax-ename->vla-object
(vl-remove-if
'listp
(mapcar 'cadr (ssnamex sset))
)
)
hiden (vl-remove tmp_blk hiden)
)
(mapcar '(lambda (x) (vla-put-Visible x :vlax-false))
hiden
)
(setq pt (mapcar '+ MinPt (list (* 0.5 DS) (* 0.5 DS))))
(vl-cmdf "_.RECTANG" (trans MinPt 0 1) (trans MaxPt 0 1))
(setq pl (vlax-ename->vla-object (entlast)))
(setq sc (1- (vla-get-count csp)))
(if
(VL-CATCH-ALL-ERROR-P
(VL-CATCH-ALL-APPLY
'(lambda ()
(vl-cmdf "_-BOUNDARY" (trans pt 0 1) "")
(while (> (getvar "CMDACTIVE") 0) (command ""))
)
)
)
(if isRus
(princ "\nНе удалось построить контур")
(princ "\nIt was not possible to construct a contour")
)
)
(setq ec (vla-get-count csp))
(while (< sc ec)
(setq ret (append ret (list (vla-item csp sc)))
sc (1+ sc)
)
)
(setq ret (vl-remove pl ret))
(mapcar '(lambda (x) (vla-Erase x) (vlax-release-object x))
(list pl tmp_blk)
)
(setq pl nil
tmp_blk nil
)
(setq
ret (mapcar '(lambda (x / mipt)
(vla-GetBoundingBox x 'MiPt nil) ;_Границы блока
(setq MiPt (vlax-safearray->list MiPt))
(list MiPt x)
)
ret
)
)
(setq ret (vl-sort ret
'(lambda (e1 e2)
(< (distance MinPt (car e1))
(distance MinPt (car e2))
)
)
)
)
(setq pl (nth 1 ret)
ret (vl-remove pl ret)
)
(mapcar 'vla-erase (mapcar 'cadr ret))
(mapcar '(lambda (x) (vla-put-Visible x :vlax-true))
hiden
)
(foreach x loc (vla-put-lock x :vlax-true))
(if pl
(if isRus
(princ "\nНе удалось построить контур")
(princ "\nIt was not possible to construct a contour")
)
)
)
)
)
)
(VL-CATCH-ALL-APPLY
'(lambda ()
(mapcar 'vlax-release-object
(list unnamed_block tmp_blk csp blks lays)
)
)
)
)
) ;_if not
(foreach x loc (vla-put-lock x :vlax-true))
(setvar "OSMODE" osm)
(vla-endundomark adoc)
(vlax-release-object adoc)
(princ)
)
(if (= (getvar "SysCodePage") "ANSI_1251")
(princ "\nНаберите в командной строке ECO")
(princ "\nType ECO in command line")
)

c) insert hatch inside offset polyline and delete polyline by Lee Mac

Spoiler

(defun c:HH ( / *error* _StartUndo _EndUndo doc spc ent hobj hl )
(vl-load-com)
;; © Lee Mac 2010

(setq hl "Duct-HA") ;; Hatch Layer

(defun *error* ( msg )
(and doc (_EndUndo doc))
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
(princ)
)

(defun _StartUndo ( doc ) (_EndUndo doc)
(vla-StartUndoMark doc)
)

(defun _EndUndo ( doc )
(if (= 8 (logand 8 (getvar 'UNDOCTL)))
(vla-EndUndoMark doc)
)
)

(LM:ActiveSpace 'doc 'spc)

(or (tblsearch "LAYER" hl)
(vla-add (vla-get-layers doc) hl)
)

(if (setq ent (LM:Selectif (lambda ( x ) (vlax-curve-isClosed x)) entsel "\nSelect Object to Hatch: "))
(progn

(_StartUndo doc)

(if
(not
(vl-catch-all-error-p
(setq hobj
(vl-catch-all-apply 'vla-AddHatch
(list spc acHatchPatternTypePredefined "ANSI37" :vlax-false 0)
)
)
)
)
(progn
(vlax-invoke hobj 'AppendOuterLoop (list (vlax-ename->vla-object ent)))
(mapcar
'(lambda ( p v ) (vlax-put-property hobj p v))
'(Layer AssociativeHatch PatternAngle PatternScale) (list hl :vlax-false 0.0 32.0)
)
(vla-Evaluate hobj)
(entdel ent)
)
(princ (strcat "\n** Error: " (vl-catch-all-error-message hobj) " **"))
)

(_EndUndo doc)
)
)

(princ)
)

;;---------------------=={ Select if }==----------------------;;
;; ;;
;; Continuous selection prompts until the predicate function ;;
;; foo is validated ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; foo - optional predicate function taking ename argument ;;
;; fun - selection function to invoke ;;
;; str - prompt string ;;
;;------------------------------------------------------------;;
;; Returns: selected entity ename if successful, else nil ;;
;;------------------------------------------------------------;;

(defun LM:Selectif ( foo fun str / e )
;; © Lee Mac 2010
(while
(progn (setq e (car (fun str)))
(cond
( (eq 'ENAME (type e))

(if (and foo (not (foo e)))
(princ "\n** Invalid Object Selected **")
)
)
)
)
)
e
)

;;--------------------=={ ActiveSpace }==---------------------;;
;; ;;
;; Retrieves pointers to the Active Document and Space ;;
;;------------------------------------------------------------;;
;; Author: Lee McDonnell, 2010 ;;
;; ;;
;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;;
;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; *doc - quoted symbol other than *doc ;;
;; *spc - quoted symbol other than *spc ;;
;;------------------------------------------------------------;;

(defun LM:ActiveSpace ( *doc *spc )
;; © Lee Mac 2010
(set *spc
(if
(or
(eq AcModelSpace
(vla-get-ActiveSpace
(set *doc
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
)
)
(eq :vlax-true (vla-get-MSpace (eval *doc)))
)
(vla-get-ModelSpace (eval *doc))
(vla-get-PaperSpace (eval *doc))
)
)
)

Thanks

[Kent1Cooper]

---

@s_plant wrote:

...

I managed to define two separate routine which they get "Block Rotation" as HROT and "Dynamic Block Orientation Value" as HORI to align HPANG with block and insert the hatch.

.... how can I combine these two lisp in a math formula to get HPANG right?! .... 

---

It looks to me as though in every illustrated case, simply subtracting HORI from HROT, or in AutoLisp terms:

(- HROT HORI)

gives you the proper angle.

[sam_safinia]

Sorry but I didn't get your point mate?!

[Kent1Cooper]

---

@s_plant wrote:
Sorry but I didn't get your point mate?!

---

Just answering the question in the portion of your message quoted at the top of mine.  To extend it a little further to the logical conclusion:  Assuming that HROT and HORI are expressed in radians, as they will be if extracted from Block data unconverted, and since the HPANG System Variable is also stored in radians:

(setvar 'hpang (- HROT HORI)) ; red part from my previous Reply

would appear to set the Hatch angle to what you describe as the "proper angle" in every case that you illustrate, without the need to go through your longer equations involving subtracting something from 360 and then subtracting 360 from something else.  An AutoLisp equation could certainly be constructed to do it the longer way, but I don't think that's needed.  [I suppose there could possibly be other circumstances that you don't illustrate in which this would not give the correct result -- write back if that turns out to be the case.]

[sam_safinia]

Thanks Kent. That makes sense.

I got proper angle for most of my segments except some with rotated angle which I'm not worry about them. It can be fixed by MP. I couldn't fix double up selection prompt. The lisp is working fine but need to select block twice and Enter....

Spoiler

(defun dynval ( blk prop )
(setq prop (strcase prop))
(vl-some '(lambda ( x ) (if (= prop (strcase (vla-get-propertyname x))) (vlax-get x 'value)))
(vlax-invoke blk 'getdynamicblockproperties)
)
)
(defun c:HORI ( / ee oriang hhang )
(if (and (setq ee (car (entsel "\nSelect block: ")))
(= "INSERT" (cdr (assoc 0 (entget ee))))
)
(setq oriang (dynval (vlax-ename->vla-object ee) "Orientation")))
(setq ss (ssget '((0 . "INSERT"))))
(initget (+ 1))
(terpri)
(setq count 0)
(while (< count (sslength ss))
(setq e (entget(ssname ss count)))
(setq en (cdar e))
(setq rotang (cdr(assoc 50 e)))
(setq rotang (/ (* rotang 180.0)pi))
(setq oriang (/ (* oriang 180.0)pi))
(command "_.bhatch")
(while (> (getvar 'cmdactive) 0) (command pause))
;(command "hatch" "P" "ANSI31" "200" ( + rotang oriang ) "S" pause "" "")
(setq count (+ count 1))
(princ)
)
(setq ss nil)
)

I tried to corporate modified lisp with my original lisp on my initial post with no success!! I'll start new thread for that.

Cheers

[sam_safinia · Accepted solution]

Solved!