Help for a lisp problem

[LionelB]

Hello ! Sorry for my english

I have a problem with a lisp

Its a modified lee mac lisp for a double decade and a hatch in the middle of it

 

My problem is that i want a solid hatch with a 40 fade but ive try a lot of things and none of its works, my hatch got no fade

 

Here's the code 

(defun c:zonesynthese

    ( / *error* _reversepoly _substonce _substlast en1 en2 hat inc ob1 ob2 obj sel spc tmp )

    (defun *error* ( msg )
        (LM:endundo (LM:acdoc))
        (if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
            (princ (strcat "\nError: " msg))
        )
        (princ)
    )

    (defun _reversepoly ( enx / _polydata lst wid )

        (defun _polydata ( enx )
            (if (setq enx (member (assoc 10 enx) enx))
                (vl-list*
                    (assoc 10 enx)
                    (assoc 40 enx)
                    (assoc 41 enx)
                    (assoc 42 enx)
                    (_polydata (cdr enx))
                )
            )
        )

        (setq wid (cdr (assoc 40 enx))
              enx (reverse (_polydata enx))
              enx (append (cdddr enx) (list (car enx) (cadr enx) (caddr enx)))
        )
        (while enx
            (setq lst
                (vl-list*
                    (cons 42 (- (cdr (assoc 42 enx))))
                    (cons 41 (cdr (assoc 40 enx)))
                    (cons 40 (cdr (assoc 41 enx)))
                    (assoc 10 enx)
                    lst
                )
                enx (cddddr enx)
            )
        )
        (reverse (vl-list* '(42 . 0.0) (cons 41 wid) (cons 40 wid) (cdddr lst)))
    )

    (defun _substonce ( a b l )
        (if l
            (if (equal b (car l))
                (cons a (cdr l))
                (cons (car l) (_substonce a b (cdr l)))
            )
        )
    )

    (defun _substlast ( a b l )
        (reverse (_substonce a b (reverse l)))
    )

    (cond
        (   (= 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar 'clayer))))))
            (princ "\nCurrent layer locked.")
        )
        (   (progn (initget 6)
                (and
                    (setq *offset*
                        (cond
                            (   (getdist
                                    (strcat "\nSpecify Offset"
                                        (if *offset* (strcat " <" (rtos *offset*) ">: ") ": ")
                                    )
                                )
                            )
                            (   *offset*   )
                        )
                    )
                    (setq sel (LM:ssget "\nSelect LWPolylines: " '("_:L" ((0 . "LWPOLYLINE")))))
                )
            )
            (setq spc (vlax-get-property (LM:acdoc) (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace)))
            (LM:startundo (LM:acdoc))
            (repeat (setq inc (sslength sel))
                (setq obj (vlax-ename->vla-object (ssname sel (setq inc (1- inc)))))
                (if
                    (and
                        (setq ob1 (car (LM:catchapply 'vlax-invoke (list obj 'offset    *offset*))))
                        (setq ob2 (car (LM:catchapply 'vlax-invoke (list obj 'offset (- *offset*)))))
                    )
                    (if (vlax-curve-isclosed obj)
                        (progn
                            (if (< (vla-get-area ob1) (vla-get-area ob2))
                                (setq tmp ob1 ob1 ob2 ob2 tmp)
                            )
(vlax-put-property ob1 'ColorIndex 255)
(vlax-put-property ob2 'ColorIndex 255)
(vlax-put-property obj 'ColorIndex 255)
                            (setq hat (vla-addhatch spc achatchpatterntypepredefined "SOLID" :vlax-true achatchobject))
                            (vlax-put-property hat 'Color 8)
                            (vlax-invoke hat 'appendouterloop (list ob1))
                            (vlax-invoke hat 'appendinnerloop (list ob2))
                            (vla-evaluate hat)
                        )
                        (progn
                            (setq en1 (entget (vlax-vla-object->ename ob1))
                                  en2 (entget (vlax-vla-object->ename ob2))
                            )
                            (entmod
                                (append
                                    (_substlast '(42 . 0.0) (assoc 42 (reverse en1))
                                        (vl-remove (assoc 210 en1)
                                            (subst
                                                (cons 90 (+ (cdr (assoc 90 en1)) (cdr (assoc 90 en2))))
                                                (assoc 90 en1)
                                                (subst
                                                    (cons 70 (logior 1 (cdr (assoc 70 en1))))
                                                    (assoc 70 en1)
                                                    en1
                                                )
                                            )
                                        )
                                    )
                                    (_reversepoly en2)
                                    (list (assoc 210 en1))
                                )
                            )
                            (vla-delete ob2)
                            (setq hat (vla-addhatch spc achatchpatterntypepredefined "SOLID" :vlax-true achatchobject))
                            (vlax-put-property hat 'Color 8)
                            (vlax-invoke hat 'appendouterloop (list ob1))
                            (vla-evaluate hat)
                        )
                    )
                )
            )
            (LM:endundo (LM:acdoc))
        )
    )
    (princ)
)

;; Catch Apply  -  Lee Mac
;; Applies a function to a list of parameters and catches any exceptions.
 
(defun LM:catchapply ( fnc prm / rtn )
    (if (not (vl-catch-all-error-p (setq rtn (vl-catch-all-apply fnc prm))))
        rtn
    )
)

;; ssget  -  Lee Mac
;; A wrapper for the ssget function to permit the use of a custom selection prompt
;;
;; Arguments:
;; msg    - selection prompt
;; params - list of ssget arguments

(defun LM:ssget ( msg params / sel )
    (princ msg)
    (setvar 'nomutt 1)
    (setq sel (vl-catch-all-apply 'ssget params))
    (setvar 'nomutt 0)
    (if (not (vl-catch-all-error-p sel)) sel)
)

;; Start Undo  -  Lee Mac
;; Opens an Undo Group.

(defun LM:startundo ( doc )
    (LM:endundo doc)
    (vla-startundomark doc)
)

;; End Undo  -  Lee Mac
;; Closes an Undo Group.

(defun LM:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;; Active Document  -  Lee Mac
;; Returns the VLA Active Document Object

(defun LM:acdoc nil
    (eval (list 'defun 'LM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (LM:acdoc)
)
        
(vl-load-com) (princ)

 

Im also wondering if its possible to change the line around the hatch , actualy the lisp do this when i use the command on the middle line : 

 

And the perfect way i wan't this lisp is like this (40% fade on the hatch and i would like the line around the hatch always be like this and not like the middle line : 

 

I don't know if all of this is possible, i'm using autocad LT 2024

 

I'm sorry for my bad english and i hope its understandable 

 

Thank you for reading me and thank you for your help !