Functional Lisp - Just trying to simplify

[christian_paulsen98V29]

I made a lisp that allows me to assign a hatch to the face of a 3d solid. The only issue is that i have to select the face twice. Is there any way that i can just select the face one time? So that i can just have two total clicks. One to isolate the object, one to select which face to hatch.

;QUICK COMMAND TO CREATE A HATCH IN MODEL
(Defun c:MODELHATCH ()

(setvar "CMDECHO" 0)

(prompt "\nMODEL HATCH - Select object to hatch ..")
(setq SS1 (ssget))
(command "isolateobjects" SS1 "")
(prompt "\nMODEL HATCH - Select face of object to hatch ..")
(command "ucs" "f" pause "")
(command "-hatch" "p" "stars" "1" "0" pause "")
(command "unisolateobjects")

(setvar "CMDECHO" 1)
)

;how can i make it to where i select the face one time instead of twice

[marko_ribar]

Untested...

Still I think that you have to first select 3DSOLID (first click) and then to click to face you want to hatch (second click)... Nevertheless I think that I saved one click with (getvar (quote lastpoint)) intervention...

(defun c:modelhatch ( / *error* cmd sel )

  (defun *error* ( m )
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (prompt "\nSelect 3DSOLID for hatching...")
  (if (setq sel (ssget (list (cons 0 "3DSOLID"))))
    (progn
      (vl-cmdf "_.ISOLATEOBJECTS" sel "")
      (vl-cmdf "_.UCS" "_F" "\\" "")
      (vl-cmdf "_.-HATCH" "_P" "STARS" "1" "0" (getvar (quote lastpoint)) "")
      (vl-cmdf "_.UNISOLATEOBJECTS")
    )
  )
  (*error* nil)
)

[christian_paulsen98V29]

Does not work.

Weird. If i use the command one time it will change the ucs but not insert the hatch, but then if i use it a second time and click that same face it will insert the hatch. Its like the first half of the lisp is happening on the first execution, then the second half is happening on the second execution. 

I hope i explained that in a way that can be understood. If i use the command on a face that doesnt already have the ucs set to it, then it just changes the ucs. But if i use the command on a face that already has the ucs set to it, then it inserts the hatch.

If i were to use the command once it would change the ucs. If i use the command a second time on a different face it will set the ucs to that new face. The only time it inserts the hatch is if i use it on the same face twice in a row.

[marko_ribar · Accepted solution]

Here, try this version... You have to pick point on face of 3DSOLID by using 3DOSNAP system variable... It can work and without it, but it's not fully reliable to be working on those old releases of AutoCAD...

(defun c:modelhatch ( / *error* cmd osm 3do ape ucf sel ppp )

  (defun *error* ( m )
    (if ucf
      (repeat 2
        (if command-s
          (command-s "_.UCS" "_P")
          (vl-cmdf "_.UCS" "_P")
        )
      )
      (if command-s
        (command-s "_.UCS" "_P")
        (vl-cmdf "_.UCS" "_P")
      )
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.UNDO" "_E")
        (vl-cmdf "_.UNDO" "_E")
      )
    )
    (if ape
      (setvar (quote aperture) ape)
    )
    (if (getvar (quote 3dosmode))
      (if 3do
        (setvar (quote 3dosmode) 3do)
      )
    )
    (if osm
      (setvar (quote osmode) osm)
    )  
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (if (getvar (quote 3dosmode))
    (progn
      (setq 3do (getvar (quote 3dosmode)))
      (setvar (quote 3dosmode) 8)
    )
  )
  (setq ape (getvar (quote aperture)))
  (setvar (quote aperture) 10)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.UNDO" "_E")
  )
  (vl-cmdf "_.UNDO" "_BE")
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (vl-cmdf "_.UCS" "_W")
      (setq ucf t)
    )
  )
  (prompt "\nSelect 3DSOLID for hatching...")
  (if (setq sel (ssget (list (cons 0 "3DSOLID"))))
    (progn
      (vl-cmdf "_.ISOLATEOBJECTS" sel "")
      (initget 1)
      (setq ppp (getpoint "\nPick or specify face on 3DSOLID you want to hatch : "))
      (vl-cmdf "_.UCS" "_F" ppp)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (vl-cmdf "_.-HATCH" "_P" "ANSI31" "1.0" "0.0" (trans ppp 0 1))
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (vl-cmdf "_.UNISOLATEOBJECTS")
    )
  )
  (*error* nil)
)

[christian_paulsen98V29]

This one does not work. The only way it works is if i select the very bottom face of my solid which is at z = 0. This new version is not changing the ucs or anything either.

Command: MODELHATCHZZZ
Select 3DSOLID for hatching...
Select objects: Specify opposite corner: 1 found
Select objects:
Pick or specify face on 3DSOLID you want to hatch :
Valid hatch boundary not found.
No objects to unisolate.

[marko_ribar]

It works for me both in AutoCAD 2022 and in BricsCAD V23... Are you sure you picked point correctly when small blue 3DOSNAP circle appears at the center of 3DSOLID face?

[christian_paulsen98V29]

Yes i saw the blue circle pop up on faces of 3d solids.

I copied and pasted your code exactly as you posted it. Maybe thats the issue?

[marko_ribar]

But you are supposed to copy it exactly as I posted it... You select the code with mouse which will mark the code with blue selection, then you press ctrl+c (copy); you open blank document in notepad, or notepad++ and press ctrl+V (paste) and then you save document as "modelhatch.lsp"... Then you start AutoCAD or BricsCAD and type in command prompt "APPLOAD" command and then navigate to your previously saved document "modelhatch.lsp" and press load... It should load file successful at prompt where all other stuff is loaded within CAD initialization... Then you create BOX 3DSOLID or something that have flat 3DFACES - hatching only works with flat faces, and then you type "MODELHATCH" at command prompt... The rest is what routine is supposed to ask you to do... If everything passes correctly (selecting 3DSOLID, picking 3DFACE with small blue circle 3DOSNAP), CAD should hatch your desired face... That's all and it works for me...

[marko_ribar]

You know what,

You probably need to specify smaller scale factor of hatching - it was hardcoded as "1.0", but have you tried with "0.1"...

Here is my final code, but instead of simplifying to 2 clicks it'll ask for hatch name, scale factor and rotation of hatching... Nevertheless, I'd keep latest code posted here, as it is the most user friendly and nothing is hard coded - it should ask for hatch pattern name for which I placed "ANSI31" as starting default, as BricsCAD doesn't have "STARS" in default pattern built-in list... Also because JOIN command is somewhat phallic, you should load (c:joinlsp) separately and only then perform (c:modelhatch) as (c:modelhatch) is calling (c:joinlsp)...

(defun c:joinlsp ( / *error* peditss joinss cs qaf cmd ss ssli i li lil l1 l2 lil1 lil1l s el p1 p2 p3 p4 pp pp1 pp2 sp xx ucsf )

  (defun *error* ( m )
    (if qaf (setvar (quote qaflags) qaf))
    (if cmd (setvar (quote cmdecho) cmd))
    (if m (prompt m))
    (princ)
  )

  (defun peditss ( ss )
    (if (= (strcase (getvar (quote program))) "ACAD")
      (progn
        (initcommandversion 2)
        (vl-cmdf "_.pedit" "_m" ss)
      )
      (vl-cmdf "_.pedit" "_m" ss)
    )
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
  )

  (defun joinss ( ss )
    (if (= (strcase (getvar (quote program))) "ACAD")
      (progn
        (initcommandversion 2)
        (vl-cmdf "_.join" ss)
      )
      (vl-cmdf "_.join" ss)
    )
    (while (< 0 (getvar (quote cmdactive)))
      (vl-cmdf "")
    )
  )

  (defun cs ( s1 en / df ex fl fz in l1 l2 s2 sf vl el elpts pts p el1 xx pp ell )

    (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

    (setq fz 1e-6) ;; Point comparison tolerance

    (if s1
      (if en
        (progn
          (setq s2 (ssadd)
            l1 (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en))
          )
          (repeat (setq in (sslength s1))
            (setq en (ssname s1 (setq in (1- in)))
              vl (cons (list (vlax-curve-getstartpoint en) (vlax-curve-getendpoint en) en) vl)
            )
          )
          (while
            (progn
              (foreach v vl
                (if (vl-some (function (lambda ( p ) (or (equal (car v) p fz) (equal (cadr v) p fz)))) l1)
                  (setq s2 (ssadd (caddr v) s2)
                        l1 (vl-list* (car v) (cadr v) l1)
                        fl t
                  )
                  (setq l2 (cons v l2))
                )
              )
              fl
            )
            (setq vl l2 l2 nil fl nil)
          )
        )
      )
    )
    (setq el (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s2))))
    (setq elpts (mapcar (function (lambda ( x ) (list (vlax-curve-getstartpoint x) (vlax-curve-getendpoint x) x))) el))
    (setq pts (mapcar (function (lambda ( x ) (list (vlax-curve-getstartpoint x) (vlax-curve-getendpoint x)))) el))
    (setq p (vl-some (function (lambda ( x ) (if (= (length (vl-remove-if (function (lambda ( y ) (equal x y fz))) (apply (function append) pts))) (1- (length (apply (function append) pts)))) x))) (apply (function append) pts)))
    (if (not p)
      (setq p (caar elpts))
    )
    (setq el1 (vl-some (function (lambda ( x ) (if (vl-member-if (function (lambda ( y ) (equal p y fz))) x) x))) elpts))
    (setq elpts (vl-remove el1 elpts))
    (setq elpts (cons el1 elpts))
    (while (setq xx (car elpts))
      (setq ell (cons (caddr xx) ell))
      (setq elpts (vl-remove xx elpts))
      (setq pp (car (vl-remove-if (function (lambda ( x ) (equal x p fz))) (reverse (cdr (reverse xx))))))
      (setq el1 (vl-some (function (lambda ( x ) (if (vl-member-if (function (lambda ( y ) (equal pp y fz))) x) x))) elpts))
      (if el1
        (progn
          (setq elpts (vl-remove el1 elpts))
          (setq elpts (cons el1 elpts))
        )
      )
      (setq p pp)
    )
    ell
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq qaf (getvar (quote qaflags)))
  (setvar (quote qaflags) 1)
  (if (setq ss (ssget "_:L-I"))
    (progn
      (setq ssli (ssget "_P" (list (cons 0 "LINE,ARC,CIRCLE,*POLYLINE,SPLINE,ELLIPSE,HELIX"))))
      (repeat (setq i (sslength ssli))
        (setq li (ssname ssli (setq i (1- i))))
        (setq lil (cons li lil))
      )
      (while (setq l1 (car lil))
        (setq lil1 (cs ssli l1))
        (setq lil (vl-remove-if (function (lambda ( x ) (vl-position x lil1))) lil))
        (setq lil1l (cons lil1 lil1l))
      )
      (foreach lil1 lil1l
        (setq s (ssadd))
        (foreach li lil1
          (ssadd li s)
          (ssdel li ss)
        )
        (cond
          ( (and (> (sslength s) 1) (vl-every (function (lambda ( x ) (= (cdr (assoc 0 (entget x))) "LINE"))) (setq el (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s))))))
            (setq el (mapcar (function (lambda ( a b ) (list a b))) el (cdr el)))
            (while (and (setq xx (car el)) (not ucsf))
              (setq l1 (car xx) l2 (cadr xx))
              (setq p1 (cdr (assoc 10 (entget l1))) p2 (cdr (assoc 11 (entget l1))))
              (setq p3 (cdr (assoc 10 (entget l2))) p4 (cdr (assoc 11 (entget l2))))
              (cond
                ( (equal p1 p3 1e-6)
                  (setq pp p1 pp1 p2 pp2 p4)
                )
                ( (equal p1 p4 1e-6)
                  (setq pp p1 pp1 p2 pp2 p3)
                )
                ( (equal p2 p3 1e-6)
                  (setq pp p2 pp1 p1 pp2 p4)
                )
                ( (equal p2 p4 1e-6)
                  (setq pp p2 pp1 p1 pp2 p3)
                )
              )
              (if (not (equal (distance pp1 pp2) (+ (distance pp1 pp) (distance pp pp2)) 1e-8))
                (progn
                  (setq ucsf t)
                  (vl-cmdf "_.ucs" "_3p" "_non" (trans pp1 0 1) "_non" (trans pp 0 1) "_non" (trans pp2 0 1))
                )
              )
              (setq el (cdr el))
            )
            (setq el (entlast) sp (ssadd))
            (peditss s)
            (if (not (eq el (entlast)))
              (while (setq el (entnext el))
                (ssadd el sp)
              )
            )
            (joinss sp)
            (if ucsf
              (progn
                (setq ucsf nil)
                (vl-cmdf "_.ucs" "_p")
              )
            )
          )
          ( (and (> (sslength s) 1) (vl-every (function (lambda ( x ) (wcmatch (cdr (assoc 0 (entget x))) "LINE,ARC,*POLYLINE"))) (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))))
            (setq el (vl-remove-if-not (function (lambda ( x ) (= (cdr (assoc 0 (entget x))) "LINE"))) (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex s)))) sp (ssadd))
            (foreach li el
              (ssadd li sp)
              (ssdel li s)
            )
            (setq el (entlast))
            (if (> (sslength sp) 0)
              (progn
                (peditss sp)
                (if (not (eq el (entlast)))
                  (while (setq el (entnext el))
                    (ssadd el s)
                  )
                )
              )
            )
            (joinss s)
          )
          ( t
            (joinss s)
          )
        )
      )
      (if (/= (sslength ss) 0)
        (joinss ss)
      )
    )
  )
  (*error* nil)
)

(defun c:modelhatch ( / *error* ftoa cmd osm hpg pea 3do ucf sel sss pat ell enx elx rgs pts ori pt1 pt2 ppp ) ;;; *pat* ; *scf* ; *rot* - global variables ;;;

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m )
    (if ucf
      (if command-s
        (command-s "_.ucs" "_p")
        (vl-cmdf "_.ucs" "_p")
      )
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_e")
        (vl-cmdf "_.undo" "_e")
      )
    )
    (if (getvar (quote 3dosmode))
      (if 3do
        (setvar (quote 3dosmode) 3do)
      )
    )
    (if pea
      (setvar (quote peditaccept) pea)
    )
    (if hpg
      (setvar (quote hpgaptol) hpg)
    )
    (if osm
      (setvar (quote osmode) osm)
    )  
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun ftoa ( n / m a s b )
    (if (numberp n)
      (progn
        (setq m (fix ((if (< n 0) - +) n 1e-8)))
        (setq a (abs (- n m)))
        (setq m (itoa m))
        (setq s "")
        (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
          (setq s (strcat s (itoa b)))
          (setq a (- (* a 10.0) b))
        )
        (if (= (type n) (quote int))
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (setq hpg (getvar (quote hpgaptol)))
  (setvar (quote hpgaptol) 1)
  (setq pea (getvar (quote peditaccept)))
  (setvar (quote peditaccept) 1)
  (if (getvar (quote 3dosmode))
    (progn
      (setq 3do (getvar (quote 3dosmode)))
      (setvar (quote 3dosmode) 8)
    )
  )
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.undo" "_e")
  )
  (vl-cmdf "_.undo" "_be")
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (vl-cmdf "_.ucs" "_w")
      (setq ucf t)
    )
  )
  (prompt "\nPick 3DSOLID for hatching...")
  (if (setq sel (ssget "_+.:E:S:L" (list (cons 0 "3DSOLID"))))
    (progn
      (setq pat (getstring (strcat "\nChoose hatch pattern <" (setq *pat* (if (not *pat*) "ANSI31" *pat*)) "> : ")))
      (if (= "" pat)
        (setq pat *pat*)
        (setq *pat* pat)
      )
      (initget 6)
      (setq *scf* (cond ( (getreal (strcat "\nSpecify scale factor for hatching <" (ftoa (setq *scf* (if (not *scf*) 1.0 *scf*))) "> : ")) ) ( t *scf* )))
      (initget 4)
      (setq *rot* (cond ( (getreal (strcat "\nSpecify rotation of hatch <" (ftoa (setq *rot* (if (not *rot*) 0.0 *rot*))) "> : ")) ) ( t *rot* )))
      (initget 1)
      (setq ppp (getpoint "\nPick or specify point on plane you wish to hatch - only when small blue circle appears... : "))
      (vl-cmdf "_.isolateobjects" sel)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (setq ent (ssname sel 0))
      (vl-cmdf "_.copy" ent "" (list 0.0 0.0 0.0) (list 0.0 0.0 0.0))
      (setq ell (entlast))
      (vl-cmdf "_.explode" "_l")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (while (setq ell (entnext ell))
        (if (= (cdr (assoc 0 (setq enx (entget ell)))) "REGION")
          (setq rgs (cons ell rgs))
          (if (or (= (cdr (assoc 0 enx)) "SURFACE") (= (cdr (assoc 0 enx)) "BODY"))
            (entdel ell)
          )
        )
      )
      (foreach ell rgs
        (setq elx (entlast))
        (vl-cmdf "_.explode" ell)
        (while (< 0 (getvar (quote cmdactive)))
          (vl-cmdf "")
        )
        (setq sss (ssadd))
        (while (setq elx (entnext elx))
          (ssadd elx sss)
        )
        (foreach ent (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex sss)))
          (if (or (= (cdr (assoc 0 (setq enx (entget ent)))) "CIRCLE") (and (= (cdr (assoc 0 enx)) "ELLIPSE") (equal (cdr (assoc 42 enx)) (* 2 pi) 1e-14)))
            (setq ori (vlax-curve-getstartpoint ent) pt1 (vlax-curve-getpointatparam ent (+ (vlax-curve-getstartparam ent) (/ (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)) 3.0))) pt2 (vlax-curve-getpointatparam ent (+ (vlax-curve-getstartparam ent) (* 2.0 (/ (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)) 3.0)))))
            (setq pts (cons (list (vlax-curve-getstartpoint ent) (vlax-curve-getpointatparam ent (+ (vlax-curve-getstartparam ent) (/ (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)) 2.0)))) pts))
          )
        )
        (if pts
          (progn
            (setq ori (caar pts))
            (setq pt1 (cadar pts))
            (setq pt2 (cadadr pts))
          )
        )
        (if (and ori pt1 pt2 (not (equal ori pt1 1e-6)) (not (equal ori pt2 1e-6)) (not (equal pt1 pt2 1e-6)))
          (progn
            (vl-cmdf "_.ucs" "_3p" "_non" ori "_non" pt1 "_non" pt2)
            (sssetfirst nil sss)
            (c:joinlsp)
            (while (< 0 (getvar (quote cmdactive)))
              (vl-cmdf "")
            )
            (setq elx (entlast))
            (if (equal (caddr (trans ppp 0 1)) 0.0 1e-6)
              (progn
                (vl-cmdf "_.-hatch" "_s" elx "" "_p" pat *scf* *rot*)
                (while (< 0 (getvar (quote cmdactive)))
                  (vl-cmdf "")
                )
              )
            )
            (if (and elx (not (vlax-erased-p elx)))
              (entdel elx)
            )
            (setq pts nil ori nil pt1 nil pt2 nil)
            (vl-cmdf "_.ucs" "_p")
          )
        )
      )
      (vl-cmdf "_.unisolateobjects")
    )
  )
  (*error* nil)
)

[marko_ribar]

Hi, it's me again...

If you want to hatch whole 3DSOLID, try this new version of "modelhatch"... Also because JOIN command is somewhat phallic, you should load (c:joinlsp) separately and only then perform (c:modelhatch-all) as (c:modelhatch-all) is calling (c:joinlsp)...

(defun c:modelhatch-all ( / *error* ftoa cmd osm hpg ucf sel sss pat ell enx elx rgs pts ori pt1 pt2 i ) ;;; *pat* ; *scf* ; *rot* - global variables ;;;

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m )
    (if ucf
      (if command-s
        (command-s "_.ucs" "_p")
        (vl-cmdf "_.ucs" "_p")
      )
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_e")
        (vl-cmdf "_.undo" "_e")
      )
    )
    (if hpg
      (setvar (quote hpgaptol) hpg)
    )
    (if osm
      (setvar (quote osmode) osm)
    )  
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun ftoa ( n / m a s b )
    (if (numberp n)
      (progn
        (setq m (fix ((if (< n 0) - +) n 1e-8)))
        (setq a (abs (- n m)))
        (setq m (itoa m))
        (setq s "")
        (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
          (setq s (strcat s (itoa b)))
          (setq a (- (* a 10.0) b))
        )
        (if (= (type n) (quote int))
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (setq hpg (getvar (quote hpgaptol)))
  (setvar (quote hpgaptol) 1)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.undo" "_e")
  )
  (vl-cmdf "_.undo" "_be")
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (vl-cmdf "_.ucs" "_w")
      (setq ucf t)
    )
  )
  (prompt "\nPick 3DSOLID entities for hatching...")
  (if (setq sel (ssget "_:L" (list (cons 0 "3DSOLID"))))
    (progn
      (setq pat (getstring (strcat "\nChoose hatch pattern <" (setq *pat* (if (not *pat*) "ANSI31" *pat*)) "> : ")))
      (if (= "" pat)
        (setq pat *pat*)
        (setq *pat* pat)
      )
      (initget 6)
      (setq *scf* (cond ( (getreal (strcat "\nSpecify scale factor for hatching <" (ftoa (setq *scf* (if (not *scf*) 1.0 *scf*))) "> : ")) ) ( t *scf* )))
      (initget 4)
      (setq *rot* (cond ( (getreal (strcat "\nSpecify rotation of hatch <" (ftoa (setq *rot* (if (not *rot*) 0.0 *rot*))) "> : ")) ) ( t *rot* )))
      (vl-cmdf "_.isolateobjects" sel)
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (repeat (setq i (sslength sel))
        (setq ent (ssname sel (setq i (1- i))))
        (vl-cmdf "_.copy" ent "" (list 0.0 0.0 0.0) (list 0.0 0.0 0.0))
        (setq ell (entlast))
        (vl-cmdf "_.explode" "_l")
        (while (< 0 (getvar (quote cmdactive)))
          (vl-cmdf "")
        )
        (while (setq ell (entnext ell))
          (if (= (cdr (assoc 0 (setq enx (entget ell)))) "REGION")
            (setq rgs (cons ell rgs))
            (if (or (= (cdr (assoc 0 enx)) "SURFACE") (= (cdr (assoc 0 enx)) "BODY"))
              (entdel ell)
            )
          )
        )
        (foreach ell rgs
          (setq elx (entlast))
          (vl-cmdf "_.explode" ell)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
          (setq sss (ssadd))
          (while (setq elx (entnext elx))
            (ssadd elx sss)
          )
          (foreach ent (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex sss)))
            (if (or (= (cdr (assoc 0 (setq enx (entget ent)))) "CIRCLE") (and (= (cdr (assoc 0 enx)) "ELLIPSE") (equal (cdr (assoc 42 enx)) (* 2 pi) 1e-14)))
              (setq ori (vlax-curve-getstartpoint ent) pt1 (vlax-curve-getpointatparam ent (+ (vlax-curve-getstartparam ent) (/ (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)) 3.0))) pt2 (vlax-curve-getpointatparam ent (+ (vlax-curve-getstartparam ent) (* 2.0 (/ (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)) 3.0)))))
              (setq pts (cons (list (vlax-curve-getstartpoint ent) (vlax-curve-getpointatparam ent (+ (vlax-curve-getstartparam ent) (/ (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)) 2.0)))) pts))
            )
          )
          (if pts
            (progn
              (setq ori (caar pts))
              (setq pt1 (cadar pts))
              (setq pt2 (cadadr pts))
            )
          )
          (if (and ori pt1 pt2 (not (equal ori pt1 1e-6)) (not (equal ori pt2 1e-6)) (not (equal pt1 pt2 1e-6)))
            (progn
              (vl-cmdf "_.ucs" "_3p" "_non" ori "_non" pt1 "_non" pt2)
              (sssetfirst nil sss)
              (c:joinlsp)
              (while (< 0 (getvar (quote cmdactive)))
                (vl-cmdf "")
              )
              (setq elx (entlast))
              (vl-cmdf "_.-hatch" "_s" elx "" "_p" pat *scf* *rot*)
              (while (< 0 (getvar (quote cmdactive)))
                (vl-cmdf "")
              )
              (if (and elx (not (vlax-erased-p elx)))
                (entdel elx)
              )
              (setq pts nil ori nil pt1 nil pt2 nil)
              (vl-cmdf "_.ucs" "_p")
            )
          )
        )
      )
      (vl-cmdf "_.unisolateobjects")
    )
  )
  (*error* nil)
)

HTH., M.R.

[marko_ribar]

I've finally updated my latest 2 codes (routines) for you @christian_paulsen98V29 ...

I am expecting some likes, or accept solution markings... Otherwise, I shell not help you anymore in the future...

Thanks in advance, M.R.

[christian_paulsen98V29]

I actually ended up sticking with the original code i posted. It was the simplest to use even though you had to click twice. The one you posted that had the circle in the center of the face was fine, but getting the snap the pop up was finnicky. 

After that you started adding a bunch of options for fill and scale and rotation which made the command too long and time consuming which i did not like but its an interesting attempt.

Then the last one you posted i copied and pasted exactly into my document and it would not work. It didn't give any errors or anything though. It just would create a bunch of lines on all the edges of the solid with no hatches.

Thank you for all your efforts on this LISP.

[marko_ribar]

Strange, I had no problems with both my last posted codes... The latest one which you used should hatch every planar face of 3DSOLID... You just have to experiment with hatching scales... I had to unlock hardcoding that you used to use, as you may need different inputs... Anyway, inputs are remembered for next usage through storing last values into global variables... I used AutoCAD 2022 and BricsCAD V23/V24 for testing and it worked with me without any odd failures like you described as bunch of lines scattered all around...

Thanks for likes and marking one example as a solution, but for further advancing I'd suggest working on those 2 latest *.lsp files...

[marko_ribar]

It seems that I had not looked very well in testings through AutoCAD... From past research, I've founded that (JOIN) command is somewhat phallic, so I coded for (c:joinlsp)... So with this my latest interventions where I added (c:joinlsp) to both (c:modelhatch) and (c:modelhatch-all), I think that now it should work flawlessly... Still have to test it once again, but I think that that's all...

Regards, M.R.

[marko_ribar]

I've added few more changes into both (c:modelhatch) and (c:modelhatch-all)... It should work now as desired, finally...

Bye, M.R.

[marko_ribar]

Just to inform...

I've simplified (c:joinlsp) and changed sligthly both (c:modelhatch) and (c:modelhatch-all)... You can test routines, on my end it passed tests...

Regards, M.R.

[christian_paulsen98V29]

Did you update one of your previous posts? I cant tell which one is the most up to date.

[marko_ribar]

Yes, I changed them promptly...

New ability to modify posts is now better than before...

2 last posts where are codes are changed just slightly, but you can copy + paste codes into *.lsp files named the same as defined command function names (modelhatch.lsp ; modelhatch-all.lsp and joinlsp.lsp)... Note that (joinlsp.lsp) must be loaded, before you start using (modelhatch.lsp and modelhatch-all.lsp)...

That's all...

HTH. M.R.

[marko_ribar]

Hi, @christian_paulsen98V29 

I've updated my codes again... I think that now they are even more reliable... As addition, here is one that can be used for hatching REGION entities in 3D...

(defun c:regionhatch ( / *error* ftoa cmd osm hpg ucf sel sss pat ell enx elx pts ori pt1 pt2 ) ;;; *pat* ; *scf* ; *rot* - global variables ;;;

  (or (not (vl-catch-all-error-p (vl-catch-all-apply (function vlax-get-acad-object) nil))) (vl-load-com))

  (defun *error* ( m )
    (if ucf
      (if command-s
        (command-s "_.ucs" "_p")
        (vl-cmdf "_.ucs" "_p")
      )
    )
    (if (= 8 (logand 8 (getvar (quote undoctl))))
      (if command-s
        (command-s "_.undo" "_e")
        (vl-cmdf "_.undo" "_e")
      )
    )
    (if hpg
      (setvar (quote hpgaptol) hpg)
    )
    (if osm
      (setvar (quote osmode) osm)
    )  
    (if cmd
      (setvar (quote cmdecho) cmd)
    )
    (if m
      (prompt m)
    )
    (princ)
  )

  (defun ftoa ( n / m a s b )
    (if (numberp n)
      (progn
        (setq m (fix ((if (< n 0) - +) n 1e-8)))
        (setq a (abs (- n m)))
        (setq m (itoa m))
        (setq s "")
        (while (and (not (equal a 0.0 1e-6)) (setq b (fix (* a 10.0))))
          (setq s (strcat s (itoa b)))
          (setq a (- (* a 10.0) b))
        )
        (if (= (type n) (quote int))
          m
          (if (= s "")
            m
            (if (and (= m "0") (< n 0))
              (strcat "-" m "." s)
              (strcat m "." s)
            )
          )
        )
      )
    )
  )

  (setq cmd (getvar (quote cmdecho)))
  (setvar (quote cmdecho) 0)
  (setq osm (getvar (quote osmode)))
  (setvar (quote osmode) 0)
  (setq hpg (getvar (quote hpgaptol)))
  (setvar (quote hpgaptol) 1)
  (if (= 8 (logand 8 (getvar (quote undoctl))))
    (vl-cmdf "_.undo" "_e")
  )
  (vl-cmdf "_.undo" "_be")
  (if (= 0 (getvar (quote worlducs)))
    (progn
      (vl-cmdf "_.ucs" "_w")
      (setq ucf t)
    )
  )
  (prompt "\nPick REGION for hatching...")
  (if (setq sel (ssget "_+.:E:S:L" (list (cons 0 "REGION"))))
    (progn
      (setq pat (getstring (strcat "\nChoose hatch pattern <" (setq *pat* (if (not *pat*) "ANSI31" *pat*)) "> : ")))
      (if (= "" pat)
        (setq pat *pat*)
        (setq *pat* pat)
      )
      (initget 6)
      (setq *scf* (cond ( (getreal (strcat "\nSpecify scale factor for hatching <" (ftoa (setq *scf* (if (not *scf*) 1.0 *scf*))) "> : ")) ) ( t *scf* )))
      (initget 4)
      (setq *rot* (cond ( (getreal (strcat "\nSpecify rotation of hatch <" (ftoa (setq *rot* (if (not *rot*) 0.0 *rot*))) "> : ")) ) ( t *rot* )))
      (setq ent (ssname sel 0))
      (vl-cmdf "_.copy" ent "" (list 0.0 0.0 0.0) (list 0.0 0.0 0.0))
      (setq ell (entlast))
      (vl-cmdf "_.explode" "_l")
      (while (< 0 (getvar (quote cmdactive)))
        (vl-cmdf "")
      )
      (setq sss (ssadd))
      (while (setq ell (entnext ell))
        (ssadd ell sss)
      )
      (foreach ent (vl-remove-if (function listp) (mapcar (function cadr) (ssnamex sss)))
        (if (or (= (cdr (assoc 0 (setq enx (entget ent)))) "CIRCLE") (and (= (cdr (assoc 0 enx)) "ELLIPSE") (equal (cdr (assoc 42 enx)) (* 2 pi) 1e-14)))
          (setq ori (vlax-curve-getstartpoint ent) pt1 (vlax-curve-getpointatparam ent (+ (vlax-curve-getstartparam ent) (/ (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)) 3.0))) pt2 (vlax-curve-getpointatparam ent (+ (vlax-curve-getstartparam ent) (* 2.0 (/ (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)) 3.0)))))
          (setq pts (cons (list (vlax-curve-getstartpoint ent) (vlax-curve-getpointatparam ent (+ (vlax-curve-getstartparam ent) (/ (- (vlax-curve-getendparam ent) (vlax-curve-getstartparam ent)) 2.0)))) pts))
        )
      )
      (if pts
        (progn
          (setq ori (caar pts))
          (setq pt1 (cadar pts))
          (setq pt2 (cadadr pts))
        )
      )
      (if (and ori pt1 pt2 (not (equal ori pt1 1e-6)) (not (equal ori pt2 1e-6)) (not (equal pt1 pt2 1e-6)))
        (progn
          (vl-cmdf "_.ucs" "_3p" "_non" ori "_non" pt1 "_non" pt2)
          (sssetfirst nil sss)
          (c:joinlsp)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
          (setq elx (entlast))
          (vl-cmdf "_.-hatch" "_s" elx "" "_p" pat *scf* *rot*)
          (while (< 0 (getvar (quote cmdactive)))
            (vl-cmdf "")
          )
          (if (and elx (not (vlax-erased-p elx)))
            (entdel elx)
          )
          (vl-cmdf "_.ucs" "_p")
        )
      )
    )
  )
  (*error* nil)
)

HTH.

M.R.

[marko_ribar]

Just to inform, I've updated my codes finally... Now you can copy + paste them into *.lsp files... I think that I won't edit them further more, but if I do something I'll promptly inform...