Convert Hatching to Polyline

September 6, 2023

6 minutes ago, SLW210 said:

I'll try to look if work gives me some slack. I have short days tomorrow and Friday so trying to get ahead.

Likewise, this one is an interesting project but you'd note my posts doing this in parts as and when work allows

September 6, 2023

3 hours ago, SLW210 said:
Exceed's is working here, doesn't delete the hatches.

I use this to remove all hatches in a drawing.
(defun c:DeHatch (/)
    (if (setq h (ssget "_X" '((0 . "HATCH"))))
        (repeat (setq a (sslength h)) (entdel (ssname h (setq a (1- a)))))
    )
    (princ)
)

i updated code for additional option for deleting original hatches (when it makes same quantity polylines).

please test it

September 6, 2023

@exceed , lisp DeHatch removes all hatches in the drawing.
You can only remove hatches replaced by polylines.

lisp HCEN (Edited yesterday at 10:51 AM by exceed)

creates only a outline???

Edited December 14, 2023 by Nikon

September 6, 2023

Try this one, might work - it does in AutoCAD

(defun c:Hatch2Poly ( / acount ss APoly MyPoly VertexList SplitHere MyWidth1 MyWidth2 MyWidth pt MyLayer thisdrawing vars MyCol MyLay)
  ;;https://www.cadtutor.net/forum/topic/24364-vertices-of-a-polyline/
  (defun mAssoc ( key lst / l x ) ;Get association list entries for 'key' value
    (foreach x lst
     (if (= key (car x))
       (setq l (cons (cdr x) l))
     ) ; end if
   ) ; end foreach
   (reverse l)
  ) ; end defun

  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object))) ; get file information
  (vla-EndUndoMark thisdrawing)                                      ; clear undo marker
  (vla-startundomark thisdrawing)                                    ; Start Undo marker

  (setq acount 0)                           ; a counter
  (princ "\n Select Hatches : ")            ; Select Hatches message
  (setq ss (ssget '((0 . "HATCH"))))        ; Select hatches

;;3 lines to disable command prompts and echo
  (setq vars '("CMDECHO"))
  (setq old (mapcar 'getvar vars)) ;;get old variables
  (mapcar 'setvar vars '(0)) ;;set variables to new

  (while (< acount (sslength ss))           ; Loop therough selection set

(setq Apoly nil
      MyPoly nil
      VertexList nil
      SplitHere nil
      MyWidth1 nil
      MyWidth2 nil
      MyWidth nil
      pt nil
      MyCol nil
      MyLay nil
) ; reset variables - something funny happened

    (command "-hatchedit" (ssname ss acount) "B" "P" "Y") ; recreate hatch boundary
    (setq MyLay (assoc 8 (entget (ssname ss acount)) ))      ; get hatch layer
    (setq MyCol (assoc 62 (entget (ssname ss acount)) ))     ; get hatch colour
    (setq APoly (entlast))                                   ; entity name for the boundary
    (setq MyPoly (entget APoly))                             ; entity assoc. list for boundary

    (setq MyPoly (subst (cons 70 0) (assoc 70 MyPoly) MyPoly ))  ;; Make as open polyline
    (setq MyPoly (subst MyLay (assoc 8 MyPoly) MyPoly ))         ;; Change Layer
    (entmod MyPoly)(entupd APoly)  
    (setq MyPoly (entget APoly))
    (if (= (cdr MyCol) nil)
      ()                                                ;; If hatch colour 'by-xyz' or not set
      (vla-put-Color (vlax-ename->vla-object APoly) (cdr MyCol) ) ;; Change Colour
    )

    (setq VertexList (massoc 10 MyPoly))    ; get list of verticies for boundary
    (setq SplitHere (nth (/ (length VertexList) 2) VertexList))  ; split boundary coordinates
;;NOTE IF HATCH HAS UNEVEN NUMBER OF VERTICIES THIS COULD GO WEIRD
    (command "._break" APoly SplitHere SplitHere)                ; Break the boundary at split


    (setq Len1 (length (mAssoc 10 (entget (entlast) )) ) ) ; verticies of last ent
    (setq Len2 (length (mAssoc 10 (entget APoly)) ) ) ; verticies of last ent
    (if (< Len1 Len2)
      (entdel (entlast))
      (progn
        (entdel APoly)
        (setq Apoly (entlast))
      )
    )
    (setq MyPOly (entget Apoly))

    (setq VertexList (massoc 10 (entget APoly) ))                ; get retained vertex list
    (setq MyWidth1 (distance (nth 1 VertexList) (nth 0 VertexList) ))  ; get last segment widths
    (setq MyWidth2 (distance (nth 1 (reverse VertexList)) (nth 0 (reverse VertexList)) ))
    (if (< MyWidth1 MyWidth2)              ; work out where to split off remaining hatch end
      (setq SplitHere (nth 1 VertexList)
            MyWidth MyWidth1               ; and the hatch width
            pt (nth 0 vertexlist)
      ) ; end setq
      (setq SplitHere (nth 1 (reverse VertexList))
            MyWidth MyWidth2
            pt (nth 0 (reverse vertexlist))
      ) ; end setq
    ) ; end if
    (command "._break" APoly SplitHere SplitHere)               ; split off and delte the end marker
    (if (< MyWidth1 MyWidth2)
      (progn
        (entdel APoly)
        (setq APoly (entlast))
      ) ; end progn
      (entdel (entlast))
    ) ; end if
    (entdel (ssname ss acount))           ; delete the hatch
    (command "offset" (/ MyWidth 2) APoly pt "")
    (entdel APoly)
    (command "._pedit" (entlast) "W" MyWidth "")

    (setq acount (+ acount 1))            ; increase counter
  ) ; end while                           ; end of while loop

  (mapcar 'setvar vars old)
  (vla-EndUndoMark thisdrawing)           ; end undo marker

  (princ)
);End

Edited September 6, 2023 by Steven P

September 6, 2023

Steven P, it doesn't work

Unknown command "-HATCHEDIT".
<object name: FFB15640>

September 6, 2023

Steven P's Hatch2Poly works fine on my 2022 AutoCAD.

Both exceed and Steven P did a great job, y'all have left me in the dust.

September 6, 2023

Thanks SLW - sure determination to make it work though from me

I'll have a look at the hatchedit to see why it might not work in other CADS

slight change to the above, see if it works

Edited September 6, 2023 by Steven P

September 7, 2023

On 9/6/2023 at 8:41 AM, exceed said:

This routine has been tested on AutoCAD 2023.

; HCEN - 2023.09.06 exceed
; Draw CenterLine in hatch (straight feature or elbow feature shape)
; for structural member systems, trays, piping, ducts, etc.,
; updated 
; - Tested in autocad 2023 and zwcad 2022.
; - color inherit & delete original hatches option. (by user input)
;  This routine requires that the two line segments have the same length 
; and that length must be the shortest length.
; Straight, 90 degree elbow, 45 degree elbow, 30 degree elbow, etc. 
; Tilted cuts or odd shapes are not supported.
;  If the r value of the elbow is small and smaller than the two line 
; segment values above, an error may occur.

(defun C:HCEN (/ *error* thisdrawing util mspace myline index entl ent pss ss pssl 
               resultformula resultsum pent pobj ptype plength plist pclosed plistlen 
               pindex distlist p1 p2 pdist distlistlen dindex memorydist 
               widthconjecture 1dist resultlen rss breakptlist breakp1 breakp2 bpllen 
               bpindex bplistlen eobjlist eobjlistlen eindex remainlist 1obj 1objtype 
               1objsp 1objep bindex rssflag b1 rsslen rsindex rsofflist rs1 rsoff1 
               rsoff2 midptlist midpt rsoff1sp rsoff1ep mindex mflag 1midpt x delindex 
               delrss mss newmss m1 oss ossl oindex oent oobj each hyp_txt ssindex 
               ssslen colorlist sssindex sscolor ssent
               coloruseranswer deleteuseranswer
              ) 
  (vl-load-com)
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (defun *error* (msg) 
    (if (/= msg "Function cancelled") 
      (princ (strcat "\nError: " msg))
    )
    (setvar 'cmdecho oldcmdecho)
    (setvar 'peditaccept oldpeditaccept)
    (vla-EndUndoMark thisdrawing)
    (princ)
  )

  ;; Round Multiple  -  Lee Mac
  ;; Rounds 'n' to the nearest multiple of 'm'
  (defun LM:roundm (n m) 
    (* m (fix ((if (minusp n) - +) (/ n (float m)) 0.5)))
  )
  ;; Round To  -  Lee Mac
  ;; Rounds 'n' to 'p' decimal places
  (defun LM:roundto (n p) 
    (LM:roundm n (expt 10.0 (- p)))
  )
  (vla-EndUndoMark thisdrawing)
  (vla-startundomark thisdrawing)
  (setq oldpeditaccept 0)
  (setq oldpeditaccept (getvar 'peditaccept))
  (setq oldcmdecho 1)
  (setq oldcmdecho (getvar 'cmdecho))
  (setvar 'peditaccept 1)
  (setvar 'cmdecho 0)

  (setq util (vla-get-utility thisdrawing))
  (setq mspace (vla-get-modelspace thisdrawing))

  (if (setq entl (entlast)) 
    (progn 
      (setq entl (entlast))
    )
    (progn 
      (setq myline (vla-addline mspace 
                                (vlax-3d-point (list 0 0 0))
                                (vlax-3d-point (list 1 1 1))
                   )
      )
      (setq entl (entlast))
    )
  )
  (setq pss (ssadd))
  (princ "\n Select Hatches : ")
  (if (setq ss (ssget '((0 . "HATCH"))))
    (progn
      (setq ssslen (sslength ss))
      (setq colorlist '())
      (setq sssindex 0)
      (setq coloruseranswer (getstring "\n Do you want to inherit the color of the hatch to the polyline? (Space Bar or any key - Yes / N - Current Color"))
      (if (= coloruseranswer nil)
        (setq coloruseranswer "Y")
        (setq coloruseranswer (strcase coloruseranswer))
      )
      (repeat ssslen 
        (setq sssent (ssname ss sssindex))
        (setq sscolor (vlax-get-property 
                        (vlax-get-property (vlax-ename->vla-object sssent) 'truecolor)
                        'colorindex
                      )
        )
        ;(princ sscolor)
        (princ "\n")
        (command "_.hatchgenerateboundary" sssent "")
        (if (/= coloruseranswer "N")
          (vlax-put-property (vlax-ename->vla-object (entlast)) 'color sscolor)
        )
        (setq sssindex (+ sssindex 1))
      )
    
      (setq ssindex 0)
      (while (setq ent (entnext entl)) 
        (ssadd ent pss)
        (if (= ssindex 0) 
          (progn 
            (if (/= myline nil) 
              (vla-delete myline)
            )
          )
        )
        (setq entl ent)
        (setq ssindex (+ ssindex 1))
      )
      (sssetfirst nil pss)
      (setq pssl (sslength pss))
      (setq index 0)
      (setq resultformula "")
      (setq resultsum 0)
      (setq mss (ssadd))
    
      (repeat pssl 
        (setq pent (ssname pss index))
        (setq pobj (vlax-ename->vla-object pent))
        (setq ptype (vlax-get-property pobj 'entityname))
        (setq plength (vlax-get-property pobj 'length))
        (setq plist (vlax-safearray->list 
                      (vlax-variant-value (vlax-get-property pobj 'coordinates))
                    )
        )
        (setq pclosed (vlax-get-property pobj 'closed))
        (if (= pclosed :vlax-true) 
          (progn 
            (setq plist (append plist (list (car plist) (cadr plist))))
          )
          (progn)
        )
        (setq plistlen (length plist))
        (setq pindex 0)
        (setq distlist '())
        (repeat (- (/ plistlen 2) 1) 
          (setq p1 (list (nth pindex plist) (nth (+ pindex 1) plist)))
          (setq p2 (list (nth (+ pindex 2) plist) (nth (+ pindex 3) plist)))
          (setq pdist (distance p1 p2))
          (setq distlist (cons pdist distlist))
          (setq pindex (+ pindex 2))
        )
    
        (setq sorteddistlist (vl-sort distlist '<))
        (setq distlistlen (length sorteddistlist))
        (setq dindex 0)
        (setq memorydist -1)
        (setq widthconjecture 0)
        (repeat distlistlen 
          (setq 1dist (nth dindex sorteddistlist))
          (if 
            (and (= widthconjecture 0) 
                 (= (vl-princ-to-string memorydist) (vl-princ-to-string 1dist))
            )
            (setq widthconjecture 1dist)
          )
          (setq memorydist 1dist)
          (setq dindex (+ dindex 1))
        )
        (if (= widthconjecture 0)
          (setq widthconjecture (car sorteddistlist))
        )
        (setq dindex 0)
        (setq pindex 0)
        (setq breakptlist '())
        (setq distlist (reverse distlist))
        (repeat distlistlen 
          (setq 1dist (nth dindex distlist))
          (if (= (lm:roundto widthconjecture 0) (lm:roundto 1dist 0)) 
            (progn 
              (setq breakp1 (list (nth pindex plist) (nth (+ pindex 1) plist)))
              (setq breakp2 (list (nth (+ pindex 2) plist) (nth (+ pindex 3) plist)))
              (setq breakptlist (cons (list breakp1 breakp2) breakptlist))
            )
          )
          (setq dindex (+ dindex 1))
          (setq pindex (+ pindex 2))
        )
        (setq bplistlen (length breakptlist))
        (setq eobjlist (vlax-safearray->list (vlax-variant-value (vla-explode pobj))))
        (entdel pent)
        (setq eobjlistlen (length eobjlist))
        (setq eindex 0)
        (setq remainlist '())
        (setq rss (ssadd))
    
        (repeat eobjlistlen 
          (setq 1obj (nth eindex eobjlist))
          (setq 1objtype (vlax-get-property 1obj 'entityname))
          (cond 
            ((= 1objtype "AcDbArc")
             (setq remainlist (cons 1obj remainlist))
             (ssadd (vlax-vla-object->ename 1obj) rss)
            )
            ((= 1objtype "AcDbLine")
             (setq 1objsp (vlax-safearray->list 
                            (vlax-variant-value (vlax-get-property 1obj 'startpoint))
                          )
             )
             (setq 1objep (vlax-safearray->list 
                            (vlax-variant-value (vlax-get-property 1obj 'endpoint))
                          )
             )
             (if (/= (lm:roundto (distance 1objsp 1objep) 0) 0) 
               (progn 
                 (setq bindex 0)
                 (setq rssflag 0)
                 (repeat bplistlen 
                   (setq b1 (nth bindex breakptlist))
                   (if 
                     (or 
                       (and 
                         (= (lm:roundto (car (car b1)) 0) (lm:roundto (car 1objsp) 0))
                         (= (lm:roundto (cadr (car b1)) 0) 
                            (lm:roundto (cadr 1objsp) 0)
                         )
                         (= (lm:roundto (car (cadr b1)) 0) (lm:roundto (car 1objep) 0))
                         (= (lm:roundto (cadr (cadr b1)) 0) 
                            (lm:roundto (cadr 1objep) 0)
                         )
                       )
                       (and 
                         (= (lm:roundto (car (car b1)) 0) (lm:roundto (car 1objep) 0))
                         (= (lm:roundto (cadr (car b1)) 0) 
                            (lm:roundto (cadr 1objep) 0)
                         )
                         (= (lm:roundto (car (cadr b1)) 0) (lm:roundto (car 1objsp) 0))
                         (= (lm:roundto (cadr (cadr b1)) 0) 
                            (lm:roundto (cadr 1objsp) 0)
                         )
                       )
                     )
                     (progn 
                       (setq rssflag (+ rssflag 1))
                     )
                     (progn 
                     )
                   )
                   (setq bindex (+ bindex 1))
                 )
                 (if (/= rssflag 0) 
                   (progn 
                     (entdel (vlax-vla-object->ename 1obj))
                   )
                   (progn 
                     (setq remainlist (cons 1obj remainlist))
                     (ssadd (vlax-vla-object->ename 1obj) rss)
                   )
                 )
               )
               (progn 
                 (entdel (vlax-vla-object->ename 1obj))
               )
             )
            )
            (t
            )
          )
          (setq eindex (+ eindex 1))
        )
        (setq rsslen 0)
        (if rss 
          (progn 
            (setq rsslen (sslength rss))
            (setq rsindex 0)
            (setq rsofflist '())
    
            (setq bindex 0)
            (setq midptlist '())
            (repeat bplistlen 
              (setq bp1 (nth bindex breakptlist))
              (setq midpt (polar (car bp1) 
                                 (angle (car bp1) (cadr bp1))
                                 (/ (distance (car bp1) (cadr bp1)) 2)
                          )
              )
              (setq midptlist (cons midpt midptlist))
              (setq bindex (+ bindex 1))
            )
            (repeat rsslen 
              (setq rs1 (vlax-ename->vla-object (ssname rss rsindex)))
              (setq rsoff1 (car 
                             (vlax-safearray->list 
                               (vlax-variant-value 
                                 (vlax-invoke-method rs1 
                                                     'Offset
                                                     (* (/ widthconjecture 2) 1)
                                 )
                               )
                             )
                           )
              )
              (setq rsoff1sp (vlax-safearray->list 
                               (vlax-variant-value 
                                 (vlax-get-property rsoff1 'startpoint)
                               )
                             )
              )
              (setq rsoff1ep (vlax-safearray->list 
                               (vlax-variant-value (vlax-get-property rsoff1 'endpoint))
                             )
              )
              (setq miptlistlen (length midptlist))
              (setq mindex 0)
              (setq mflag 0)
              (repeat miptlistlen 
                (setq 1midpt (nth mindex midptlist))
                (if 
                  (or 
                    (and (= (rtos (car 1midpt) 2 2) (rtos (car rsoff1sp) 2 2)) 
                         (= (rtos (cadr 1midpt) 2 2) (rtos (cadr rsoff1sp) 2 2))
                    )
                    (and (= (rtos (car 1midpt) 2 2) (rtos (car rsoff1ep) 2 2)) 
                         (= (rtos (cadr rsoff1ep) 2 2) (rtos (cadr 1midpt) 2 2))
                    )
                  )
                  (progn 
                    (setq mflag (+ mflag 1))
                  )
                  (progn 
                  )
                )
                (setq mindex (+ mindex 1))
              )
              (if (= mflag 0) 
                (progn 
                  (entdel (vlax-vla-object->ename rsoff1))
                  (setq rsoff1 (car 
                                 (vlax-safearray->list 
                                   (vlax-variant-value 
                                     (vlax-invoke-method rs1 
                                                         'Offset
                                                         (* (/ widthconjecture 2) -1)
                                     )
                                   )
                                 )
                               )
                  )
                  (entdel (vlax-vla-object->ename rs1))
                )
                (progn 
                  (entdel (vlax-vla-object->ename rs1))
                )
              )
              (ssadd (vlax-vla-object->ename rsoff1) mss)
              (vlax-for x (vla-get-hyperlinks rsoff1) (vla-delete x))
              (vla-add (vlax-get-property rsoff1 'Hyperlinks) 
                       (vl-princ-to-string widthconjecture)
              )
              (setq rsindex (+ rsindex 1))
            )
          )
        )
        (setq index (+ index 1))
      )
      (setq newmss (ssadd))
      (setq mindex 0)
      (repeat (sslength mss) 
        (setq m1 (ssname mss mindex))
        ;(princ m1)
        (if (entget m1) 
          (progn 
            (ssadd m1 newmss)
          )
        )
        (setq mindex (+ mindex 1))
      )
      (sssetfirst nil newmss)
      (setq oss (ssadd))
      (setq entl (entlast))
      (command "_pedit" "_M" newmss "" "J" "0" "")
      (while (setq ent (entnext entl)) 
        (ssadd ent oss)
        (setq entl ent)
      )
      (sssetfirst nil oss)
    
      (setq ossl (sslength oss))
      (setq oindex 0)
      (repeat ossl 
        (setq oent (ssname oss oindex))
        (setq oobj (vlax-ename->vla-object oent))
        (vlax-for each (vlax-get-property oobj 'Hyperlinks) 
          (setq hyp_txt (strcat (vla-get-url each)))
        )
        (vlax-put-property oobj 'constantwidth (atoi hyp_txt))
        (vlax-for x (vla-get-hyperlinks oobj) (vla-delete x))
        (setq olen (vlax-get-property oobj 'length))
        (setq resultformula (strcat resultformula 
                                    (if (= oindex 0) "" " + ")
                                    (vl-princ-to-string olen)
                            )
        )
        (setq resultsum (+ resultsum olen))
        (setq oindex (+ oindex 1))
      )
    
      (princ "\n hatches count = ")
      (princ (sslength ss))
      (princ "\n plines count - ")
      (princ oindex)
      (princ "\n total lenght of you selected")
      (princ "\n ")
      (princ resultformula)
      (princ " = ")
      (princ resultsum)
      (command "erase" rss "")
      (command "erase" pss "")
      (if (= (sslength ss) oindex)
        (progn
          (setq deleteuseranswer (getstring "\n The number of hatches and polylines is the same. Are you sure you want to delete the original hatch? (SpaceBar or AnyKey - Yes / N - No)"))
          (if (= deleteuseranswer nil)
            (setq deleteuseranswer "Y")
            (setq deleteuseranswer (strcase deleteuseranswer))
          )
          (if (/= deleteuseranswer "N")
            (command "erase" ss "")
          )
        )
        (progn
          (princ "\n The number of hatches and polylines does not match. There may be a problem, so please check manually.")
        )
      )
      (sssetfirst nil oss)
    )
    (progn
      (princ "\n There are no hatches in the selection set. Please try again.")
    )
  )

  (setvar 'cmdecho oldcmdecho)
  (setvar 'peditaccept oldpeditaccept)
  (vla-EndUndoMark thisdrawing)
  (princ)
)

below memo is for other people who lisping. not how to use this.

there was a difference in the basic command, hatchgenerateboundary works differently in zwcad and autocad.

In autocad, length 0 line is created, and in zwcad, it does not.

Since it is the same hatch in the same drawing, there is a difference even if the boundary is a dirty issue. I didn't handle the exception for that.

even in the case of doing entdel to not exist entities. zwcad moves on to the next step without an error.

Lisp creates polylines on top of hatches, but in 2 layers...

This program offers to choose the color of the hatching. It is very comfortable.

September 11, 2023

; HCEN - 2023.09.06 exceed
; Draw CenterLine in hatch (straight feature or elbow feature shape)
; for structural member systems, trays, piping, ducts, etc.,
; updated 
; - Tested in autocad 2023 and zwcad 2022.
; - color inherit & delete original hatches option. (by user input)
;  This routine requires that the two line segments have the same length 
; and that length must be the shortest length.
; Straight, 90 degree elbow, 45 degree elbow, 30 degree elbow, etc. 
; Tilted cuts or odd shapes are not supported.
;  If the r value of the elbow is small and smaller than the two line 
; segment values above, an error may occur.

(defun C:HCEN (/ *error* thisdrawing util mspace myline index entl ent pss ss pssl 
               resultformula resultsum pent pobj ptype plength plist pclosed plistlen 
               pindex distlist p1 p2 pdist distlistlen dindex memorydist 
               widthconjecture 1dist resultlen rss breakptlist breakp1 breakp2 bpllen 
               bpindex bplistlen eobjlist eobjlistlen eindex remainlist 1obj 1objtype 
               1objsp 1objep bindex rssflag b1 rsslen rsindex rsofflist rs1 rsoff1 
               rsoff2 midptlist midpt rsoff1sp rsoff1ep mindex mflag 1midpt x delindex 
               delrss mss newmss m1 oss ossl oindex oent oobj each hyp_txt ssindex 
               ssslen colorlist sssindex sscolor ssent
               coloruseranswer deleteuseranswer
              ) 
  (vl-load-com)
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (defun *error* (msg) 
    (if (/= msg "Function cancelled") 
      (princ (strcat "\nError: " msg))
    )
    (setvar 'cmdecho oldcmdecho)
    (setvar 'peditaccept oldpeditaccept)
    (vla-EndUndoMark thisdrawing)
    (princ)
  )

  ;; Round Multiple  -  Lee Mac
  ;; Rounds 'n' to the nearest multiple of 'm'
  (defun LM:roundm (n m) 
    (* m (fix ((if (minusp n) - +) (/ n (float m)) 0.5)))
  )
  ;; Round To  -  Lee Mac
  ;; Rounds 'n' to 'p' decimal places
  (defun LM:roundto (n p) 
    (LM:roundm n (expt 10.0 (- p)))
  )
  (vla-EndUndoMark thisdrawing)
  (vla-startundomark thisdrawing)
  (setq oldpeditaccept 0)
  (setq oldpeditaccept (getvar 'peditaccept))
  (setq oldcmdecho 1)
  (setq oldcmdecho (getvar 'cmdecho))
  (setvar 'peditaccept 1)
  (setvar 'cmdecho 0)

  (setq util (vla-get-utility thisdrawing))
  (setq mspace (vla-get-modelspace thisdrawing))

  (if (setq entl (entlast)) 
    (progn 
      (setq entl (entlast))
    )
    (progn 
      (setq myline (vla-addline mspace 
                                (vlax-3d-point (list 0 0 0))
                                (vlax-3d-point (list 1 1 1))
                   )
      )
      (setq entl (entlast))
    )
  )
  (setq pss (ssadd))
  (princ "\n Select Hatches : ")
  (if (setq ss (ssget '((0 . "HATCH"))))
    (progn
      (setq ssslen (sslength ss))
      (setq colorlist '())
      (setq sssindex 0)
      (setq coloruseranswer (getstring "\n Do you want to inherit the color of the hatch to the polyline? (Space Bar or any key - Yes / N - Current Color"))
      (if (= coloruseranswer nil)
        (setq coloruseranswer "Y")
        (setq coloruseranswer (strcase coloruseranswer))
      )
      (repeat ssslen 
        (setq sssent (ssname ss sssindex))
        (setq sscolor (vlax-get-property 
                        (vlax-get-property (vlax-ename->vla-object sssent) 'truecolor)
                        'colorindex
                      )
        )
        ;(princ sscolor)
        (princ "\n")
        (command "_.hatchgenerateboundary" sssent "")
        (if (/= coloruseranswer "N")
          (vlax-put-property (vlax-ename->vla-object (entlast)) 'color sscolor)
        )
        (setq sssindex (+ sssindex 1))
      )
    
      (setq ssindex 0)
      (while (setq ent (entnext entl)) 
        (ssadd ent pss)
        (if (= ssindex 0) 
          (progn 
            (if (/= myline nil) 
              (vla-delete myline)
            )
          )
        )
        (setq entl ent)
        (setq ssindex (+ ssindex 1))
      )
      (sssetfirst nil pss)
      (setq pssl (sslength pss))
      (setq index 0)
      (setq resultformula "")
      (setq resultsum 0)
      (setq mss (ssadd))
    
      (repeat pssl 
        (setq pent (ssname pss index))
        (setq pobj (vlax-ename->vla-object pent))
        (setq ptype (vlax-get-property pobj 'entityname))
        (setq plength (vlax-get-property pobj 'length))
        (setq plist (vlax-safearray->list 
                      (vlax-variant-value (vlax-get-property pobj 'coordinates))
                    )
        )
        (setq pclosed (vlax-get-property pobj 'closed))
        (if (= pclosed :vlax-true) 
          (progn 
            (setq plist (append plist (list (car plist) (cadr plist))))
          )
          (progn)
        )
        (setq plistlen (length plist))
        (setq pindex 0)
        (setq distlist '())
        (repeat (- (/ plistlen 2) 1) 
          (setq p1 (list (nth pindex plist) (nth (+ pindex 1) plist)))
          (setq p2 (list (nth (+ pindex 2) plist) (nth (+ pindex 3) plist)))
          (setq pdist (distance p1 p2))
          (setq distlist (cons pdist distlist))
          (setq pindex (+ pindex 2))
        )
    
        (setq sorteddistlist (vl-sort distlist '<))
        (setq distlistlen (length sorteddistlist))
        (setq dindex 0)
        (setq memorydist -1)
        (setq widthconjecture 0)
        (repeat distlistlen 
          (setq 1dist (nth dindex sorteddistlist))
          (if 
            (and (= widthconjecture 0) 
                 (= (vl-princ-to-string memorydist) (vl-princ-to-string 1dist))
            )
            (setq widthconjecture 1dist)
          )
          (setq memorydist 1dist)
          (setq dindex (+ dindex 1))
        )
        (if (= widthconjecture 0)
          (setq widthconjecture (car sorteddistlist))
        )
        (setq dindex 0)
        (setq pindex 0)
        (setq breakptlist '())
        (setq distlist (reverse distlist))
        (repeat distlistlen 
          (setq 1dist (nth dindex distlist))
          (if (= (lm:roundto widthconjecture 0) (lm:roundto 1dist 0)) 
            (progn 
              (setq breakp1 (list (nth pindex plist) (nth (+ pindex 1) plist)))
              (setq breakp2 (list (nth (+ pindex 2) plist) (nth (+ pindex 3) plist)))
              (setq breakptlist (cons (list breakp1 breakp2) breakptlist))
            )
          )
          (setq dindex (+ dindex 1))
          (setq pindex (+ pindex 2))
        )
        (setq bplistlen (length breakptlist))
        (setq eobjlist (vlax-safearray->list (vlax-variant-value (vla-explode pobj))))
        (entdel pent)
        (setq eobjlistlen (length eobjlist))
        (setq eindex 0)
        (setq remainlist '())
        (setq rss (ssadd))
    
        (repeat eobjlistlen 
          (setq 1obj (nth eindex eobjlist))
          (setq 1objtype (vlax-get-property 1obj 'entityname))
          (cond 
            ((= 1objtype "AcDbArc")
             (setq remainlist (cons 1obj remainlist))
             (ssadd (vlax-vla-object->ename 1obj) rss)
            )
            ((= 1objtype "AcDbLine")
             (setq 1objsp (vlax-safearray->list 
                            (vlax-variant-value (vlax-get-property 1obj 'startpoint))
                          )
             )
             (setq 1objep (vlax-safearray->list 
                            (vlax-variant-value (vlax-get-property 1obj 'endpoint))
                          )
             )
             (if (/= (lm:roundto (distance 1objsp 1objep) 0) 0) 
               (progn 
                 (setq bindex 0)
                 (setq rssflag 0)
                 (repeat bplistlen 
                   (setq b1 (nth bindex breakptlist))
                   (if 
                     (or 
                       (and 
                         (= (lm:roundto (car (car b1)) 0) (lm:roundto (car 1objsp) 0))
                         (= (lm:roundto (cadr (car b1)) 0) 
                            (lm:roundto (cadr 1objsp) 0)
                         )
                         (= (lm:roundto (car (cadr b1)) 0) (lm:roundto (car 1objep) 0))
                         (= (lm:roundto (cadr (cadr b1)) 0) 
                            (lm:roundto (cadr 1objep) 0)
                         )
                       )
                       (and 
                         (= (lm:roundto (car (car b1)) 0) (lm:roundto (car 1objep) 0))
                         (= (lm:roundto (cadr (car b1)) 0) 
                            (lm:roundto (cadr 1objep) 0)
                         )
                         (= (lm:roundto (car (cadr b1)) 0) (lm:roundto (car 1objsp) 0))
                         (= (lm:roundto (cadr (cadr b1)) 0) 
                            (lm:roundto (cadr 1objsp) 0)
                         )
                       )
                     )
                     (progn 
                       (setq rssflag (+ rssflag 1))
                     )
                     (progn 
                     )
                   )
                   (setq bindex (+ bindex 1))
                 )
                 (if (/= rssflag 0) 
                   (progn 
                     (entdel (vlax-vla-object->ename 1obj))
                   )
                   (progn 
                     (setq remainlist (cons 1obj remainlist))
                     (ssadd (vlax-vla-object->ename 1obj) rss)
                   )
                 )
               )
               (progn 
                 (entdel (vlax-vla-object->ename 1obj))
               )
             )
            )
            (t
            )
          )
          (setq eindex (+ eindex 1))
        )
        (setq rsslen 0)
        (if rss 
          (progn 
            (setq rsslen (sslength rss))
            (setq rsindex 0)
            (setq rsofflist '())
    
            (setq bindex 0)
            (setq midptlist '())
            (repeat bplistlen 
              (setq bp1 (nth bindex breakptlist))
              (setq midpt (polar (car bp1) 
                                 (angle (car bp1) (cadr bp1))
                                 (/ (distance (car bp1) (cadr bp1)) 2)
                          )
              )
              (setq midptlist (cons midpt midptlist))
              (setq bindex (+ bindex 1))
            )
            (repeat rsslen 
              (setq rs1 (vlax-ename->vla-object (ssname rss rsindex)))
              (setq rsoff1 (car 
                             (vlax-safearray->list 
                               (vlax-variant-value 
                                 (vlax-invoke-method rs1 
                                                     'Offset
                                                     (* (/ widthconjecture 2) 1)
                                 )
                               )
                             )
                           )
              )
              (setq rsoff1sp (vlax-safearray->list 
                               (vlax-variant-value 
                                 (vlax-get-property rsoff1 'startpoint)
                               )
                             )
              )
              (setq rsoff1ep (vlax-safearray->list 
                               (vlax-variant-value (vlax-get-property rsoff1 'endpoint))
                             )
              )
              (setq miptlistlen (length midptlist))
              (setq mindex 0)
              (setq mflag 0)
              (repeat miptlistlen 
                (setq 1midpt (nth mindex midptlist))
                (if 
                  (or 
                    (and (= (rtos (car 1midpt) 2 2) (rtos (car rsoff1sp) 2 2)) 
                         (= (rtos (cadr 1midpt) 2 2) (rtos (cadr rsoff1sp) 2 2))
                    )
                    (and (= (rtos (car 1midpt) 2 2) (rtos (car rsoff1ep) 2 2)) 
                         (= (rtos (cadr rsoff1ep) 2 2) (rtos (cadr 1midpt) 2 2))
                    )
                  )
                  (progn 
                    (setq mflag (+ mflag 1))
                  )
                  (progn 
                  )
                )
                (setq mindex (+ mindex 1))
              )
              (if (= mflag 0) 
                (progn 
                  (entdel (vlax-vla-object->ename rsoff1))
                  (setq rsoff1 (car 
                                 (vlax-safearray->list 
                                   (vlax-variant-value 
                                     (vlax-invoke-method rs1 
                                                         'Offset
                                                         (* (/ widthconjecture 2) -1)
                                     )
                                   )
                                 )
                               )
                  )
                  (entdel (vlax-vla-object->ename rs1))
                )
                (progn 
                  (entdel (vlax-vla-object->ename rs1))
                )
              )
              (ssadd (vlax-vla-object->ename rsoff1) mss)
              (vlax-for x (vla-get-hyperlinks rsoff1) (vla-delete x))
              (vla-add (vlax-get-property rsoff1 'Hyperlinks) 
                       (vl-princ-to-string widthconjecture)
              )
              (setq rsindex (+ rsindex 1))
            )
          )
        )
        (setq index (+ index 1))
      )
      (setq newmss (ssadd))
      (setq mindex 0)
      (repeat (sslength mss) 
        (setq m1 (ssname mss mindex))
        ;(princ m1)
        (if (entget m1) 
          (progn 
            (ssadd m1 newmss)
          )
        )
        (setq mindex (+ mindex 1))
      )
      (sssetfirst nil newmss)
      (setq oss (ssadd))
      (setq entl (entlast))
      (command "_pedit" "_M" newmss "" "J" "0" "")
      (while (setq ent (entnext entl)) 
        (ssadd ent oss)
        (setq entl ent)
      )
      (sssetfirst nil oss)
    
      (setq ossl (sslength oss))
      (setq oindex 0)
      (repeat ossl 
        (setq oent (ssname oss oindex))
        (setq oobj (vlax-ename->vla-object oent))
        (vlax-for each (vlax-get-property oobj 'Hyperlinks) 
          (setq hyp_txt (strcat (vla-get-url each)))
        )
        (vlax-put-property oobj 'constantwidth (atoi hyp_txt))
        (vlax-for x (vla-get-hyperlinks oobj) (vla-delete x))
        (setq olen (vlax-get-property oobj 'length))
        (setq resultformula (strcat resultformula 
                                    (if (= oindex 0) "" " + ")
                                    (vl-princ-to-string olen)
                            )
        )
        (setq resultsum (+ resultsum olen))
        (setq oindex (+ oindex 1))
      )
    
      (princ "\n hatches count = ")
      (princ (sslength ss))
      (princ "\n plines count - ")
      (princ oindex)
      (princ "\n total lenght of you selected")
      (princ "\n ")
      (princ resultformula)
      (princ " = ")
      (princ resultsum)
      (command "erase" rss "")
      (command "erase" pss "")
      (if (= (sslength ss) oindex)
        (progn
          (setq deleteuseranswer (getstring "\n The number of hatches and polylines is the same. Are you sure you want to delete the original hatch? (SpaceBar or AnyKey - Yes / N - No)"))
          (if (= deleteuseranswer nil)
            (setq deleteuseranswer "Y")
            (setq deleteuseranswer (strcase deleteuseranswer))
          )
          (if (/= deleteuseranswer "N")
            (command "erase" ss "")
          )
        )
        (progn
          (princ "\n The number of hatches and polylines does not match. There may be a problem, so please check manually.")
        )
      )
      (sssetfirst nil oss)
    )
    (progn
      (princ "\n There are no hatches in the selection set. Please try again.")
    )
  )

  (setvar 'cmdecho oldcmdecho)
  (setvar 'peditaccept oldpeditaccept)
  (vla-EndUndoMark thisdrawing)
  (princ)
)

This code works in AutoCAD, but the polylines are created in 2 layers (overlay) on top of the hatching, the hatching remains under these polylines. Is it possible to fix it?

And the request is not output to the command line, and there is no way to remove the hatches...
The number of hatches and polylines is the same. Are you sure you want to delete the original hatch?
(SpaceBar or AnyKey - Yes / N - No)"))

September 12, 2023

16 hours ago, Nikon said:

; HCEN - 2023.09.06 exceed
; Draw CenterLine in hatch (straight feature or elbow feature shape)
; for structural member systems, trays, piping, ducts, etc.,
; updated 
; - Tested in autocad 2023 and zwcad 2022.
; - color inherit & delete original hatches option. (by user input)
;  This routine requires that the two line segments have the same length 
; and that length must be the shortest length.
; Straight, 90 degree elbow, 45 degree elbow, 30 degree elbow, etc. 
; Tilted cuts or odd shapes are not supported.
;  If the r value of the elbow is small and smaller than the two line 
; segment values above, an error may occur.

(defun C:HCEN (/ *error* thisdrawing util mspace myline index entl ent pss ss pssl 
               resultformula resultsum pent pobj ptype plength plist pclosed plistlen 
               pindex distlist p1 p2 pdist distlistlen dindex memorydist 
               widthconjecture 1dist resultlen rss breakptlist breakp1 breakp2 bpllen 
               bpindex bplistlen eobjlist eobjlistlen eindex remainlist 1obj 1objtype 
               1objsp 1objep bindex rssflag b1 rsslen rsindex rsofflist rs1 rsoff1 
               rsoff2 midptlist midpt rsoff1sp rsoff1ep mindex mflag 1midpt x delindex 
               delrss mss newmss m1 oss ossl oindex oent oobj each hyp_txt ssindex 
               ssslen colorlist sssindex sscolor ssent
               coloruseranswer deleteuseranswer
              ) 
  (vl-load-com)
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (defun *error* (msg) 
    (if (/= msg "Function cancelled") 
      (princ (strcat "\nError: " msg))
    )
    (setvar 'cmdecho oldcmdecho)
    (setvar 'peditaccept oldpeditaccept)
    (vla-EndUndoMark thisdrawing)
    (princ)
  )

  ;; Round Multiple  -  Lee Mac
  ;; Rounds 'n' to the nearest multiple of 'm'
  (defun LM:roundm (n m) 
    (* m (fix ((if (minusp n) - +) (/ n (float m)) 0.5)))
  )
  ;; Round To  -  Lee Mac
  ;; Rounds 'n' to 'p' decimal places
  (defun LM:roundto (n p) 
    (LM:roundm n (expt 10.0 (- p)))
  )
  (vla-EndUndoMark thisdrawing)
  (vla-startundomark thisdrawing)
  (setq oldpeditaccept 0)
  (setq oldpeditaccept (getvar 'peditaccept))
  (setq oldcmdecho 1)
  (setq oldcmdecho (getvar 'cmdecho))
  (setvar 'peditaccept 1)
  (setvar 'cmdecho 0)

  (setq util (vla-get-utility thisdrawing))
  (setq mspace (vla-get-modelspace thisdrawing))

  (if (setq entl (entlast)) 
    (progn 
      (setq entl (entlast))
    )
    (progn 
      (setq myline (vla-addline mspace 
                                (vlax-3d-point (list 0 0 0))
                                (vlax-3d-point (list 1 1 1))
                   )
      )
      (setq entl (entlast))
    )
  )
  (setq pss (ssadd))
  (princ "\n Select Hatches : ")
  (if (setq ss (ssget '((0 . "HATCH"))))
    (progn
      (setq ssslen (sslength ss))
      (setq colorlist '())
      (setq sssindex 0)
      (setq coloruseranswer (getstring "\n Do you want to inherit the color of the hatch to the polyline? (Space Bar or any key - Yes / N - Current Color"))
      (if (= coloruseranswer nil)
        (setq coloruseranswer "Y")
        (setq coloruseranswer (strcase coloruseranswer))
      )
      (repeat ssslen 
        (setq sssent (ssname ss sssindex))
        (setq sscolor (vlax-get-property 
                        (vlax-get-property (vlax-ename->vla-object sssent) 'truecolor)
                        'colorindex
                      )
        )
        ;(princ sscolor)
        (princ "\n")
        (command "_.hatchgenerateboundary" sssent "")
        (if (/= coloruseranswer "N")
          (vlax-put-property (vlax-ename->vla-object (entlast)) 'color sscolor)
        )
        (setq sssindex (+ sssindex 1))
      )
    
      (setq ssindex 0)
      (while (setq ent (entnext entl)) 
        (ssadd ent pss)
        (if (= ssindex 0) 
          (progn 
            (if (/= myline nil) 
              (vla-delete myline)
            )
          )
        )
        (setq entl ent)
        (setq ssindex (+ ssindex 1))
      )
      (sssetfirst nil pss)
      (setq pssl (sslength pss))
      (setq index 0)
      (setq resultformula "")
      (setq resultsum 0)
      (setq mss (ssadd))
    
      (repeat pssl 
        (setq pent (ssname pss index))
        (setq pobj (vlax-ename->vla-object pent))
        (setq ptype (vlax-get-property pobj 'entityname))
        (setq plength (vlax-get-property pobj 'length))
        (setq plist (vlax-safearray->list 
                      (vlax-variant-value (vlax-get-property pobj 'coordinates))
                    )
        )
        (setq pclosed (vlax-get-property pobj 'closed))
        (if (= pclosed :vlax-true) 
          (progn 
            (setq plist (append plist (list (car plist) (cadr plist))))
          )
          (progn)
        )
        (setq plistlen (length plist))
        (setq pindex 0)
        (setq distlist '())
        (repeat (- (/ plistlen 2) 1) 
          (setq p1 (list (nth pindex plist) (nth (+ pindex 1) plist)))
          (setq p2 (list (nth (+ pindex 2) plist) (nth (+ pindex 3) plist)))
          (setq pdist (distance p1 p2))
          (setq distlist (cons pdist distlist))
          (setq pindex (+ pindex 2))
        )
    
        (setq sorteddistlist (vl-sort distlist '<))
        (setq distlistlen (length sorteddistlist))
        (setq dindex 0)
        (setq memorydist -1)
        (setq widthconjecture 0)
        (repeat distlistlen 
          (setq 1dist (nth dindex sorteddistlist))
          (if 
            (and (= widthconjecture 0) 
                 (= (vl-princ-to-string memorydist) (vl-princ-to-string 1dist))
            )
            (setq widthconjecture 1dist)
          )
          (setq memorydist 1dist)
          (setq dindex (+ dindex 1))
        )
        (if (= widthconjecture 0)
          (setq widthconjecture (car sorteddistlist))
        )
        (setq dindex 0)
        (setq pindex 0)
        (setq breakptlist '())
        (setq distlist (reverse distlist))
        (repeat distlistlen 
          (setq 1dist (nth dindex distlist))
          (if (= (lm:roundto widthconjecture 0) (lm:roundto 1dist 0)) 
            (progn 
              (setq breakp1 (list (nth pindex plist) (nth (+ pindex 1) plist)))
              (setq breakp2 (list (nth (+ pindex 2) plist) (nth (+ pindex 3) plist)))
              (setq breakptlist (cons (list breakp1 breakp2) breakptlist))
            )
          )
          (setq dindex (+ dindex 1))
          (setq pindex (+ pindex 2))
        )
        (setq bplistlen (length breakptlist))
        (setq eobjlist (vlax-safearray->list (vlax-variant-value (vla-explode pobj))))
        (entdel pent)
        (setq eobjlistlen (length eobjlist))
        (setq eindex 0)
        (setq remainlist '())
        (setq rss (ssadd))
    
        (repeat eobjlistlen 
          (setq 1obj (nth eindex eobjlist))
          (setq 1objtype (vlax-get-property 1obj 'entityname))
          (cond 
            ((= 1objtype "AcDbArc")
             (setq remainlist (cons 1obj remainlist))
             (ssadd (vlax-vla-object->ename 1obj) rss)
            )
            ((= 1objtype "AcDbLine")
             (setq 1objsp (vlax-safearray->list 
                            (vlax-variant-value (vlax-get-property 1obj 'startpoint))
                          )
             )
             (setq 1objep (vlax-safearray->list 
                            (vlax-variant-value (vlax-get-property 1obj 'endpoint))
                          )
             )
             (if (/= (lm:roundto (distance 1objsp 1objep) 0) 0) 
               (progn 
                 (setq bindex 0)
                 (setq rssflag 0)
                 (repeat bplistlen 
                   (setq b1 (nth bindex breakptlist))
                   (if 
                     (or 
                       (and 
                         (= (lm:roundto (car (car b1)) 0) (lm:roundto (car 1objsp) 0))
                         (= (lm:roundto (cadr (car b1)) 0) 
                            (lm:roundto (cadr 1objsp) 0)
                         )
                         (= (lm:roundto (car (cadr b1)) 0) (lm:roundto (car 1objep) 0))
                         (= (lm:roundto (cadr (cadr b1)) 0) 
                            (lm:roundto (cadr 1objep) 0)
                         )
                       )
                       (and 
                         (= (lm:roundto (car (car b1)) 0) (lm:roundto (car 1objep) 0))
                         (= (lm:roundto (cadr (car b1)) 0) 
                            (lm:roundto (cadr 1objep) 0)
                         )
                         (= (lm:roundto (car (cadr b1)) 0) (lm:roundto (car 1objsp) 0))
                         (= (lm:roundto (cadr (cadr b1)) 0) 
                            (lm:roundto (cadr 1objsp) 0)
                         )
                       )
                     )
                     (progn 
                       (setq rssflag (+ rssflag 1))
                     )
                     (progn 
                     )
                   )
                   (setq bindex (+ bindex 1))
                 )
                 (if (/= rssflag 0) 
                   (progn 
                     (entdel (vlax-vla-object->ename 1obj))
                   )
                   (progn 
                     (setq remainlist (cons 1obj remainlist))
                     (ssadd (vlax-vla-object->ename 1obj) rss)
                   )
                 )
               )
               (progn 
                 (entdel (vlax-vla-object->ename 1obj))
               )
             )
            )
            (t
            )
          )
          (setq eindex (+ eindex 1))
        )
        (setq rsslen 0)
        (if rss 
          (progn 
            (setq rsslen (sslength rss))
            (setq rsindex 0)
            (setq rsofflist '())
    
            (setq bindex 0)
            (setq midptlist '())
            (repeat bplistlen 
              (setq bp1 (nth bindex breakptlist))
              (setq midpt (polar (car bp1) 
                                 (angle (car bp1) (cadr bp1))
                                 (/ (distance (car bp1) (cadr bp1)) 2)
                          )
              )
              (setq midptlist (cons midpt midptlist))
              (setq bindex (+ bindex 1))
            )
            (repeat rsslen 
              (setq rs1 (vlax-ename->vla-object (ssname rss rsindex)))
              (setq rsoff1 (car 
                             (vlax-safearray->list 
                               (vlax-variant-value 
                                 (vlax-invoke-method rs1 
                                                     'Offset
                                                     (* (/ widthconjecture 2) 1)
                                 )
                               )
                             )
                           )
              )
              (setq rsoff1sp (vlax-safearray->list 
                               (vlax-variant-value 
                                 (vlax-get-property rsoff1 'startpoint)
                               )
                             )
              )
              (setq rsoff1ep (vlax-safearray->list 
                               (vlax-variant-value (vlax-get-property rsoff1 'endpoint))
                             )
              )
              (setq miptlistlen (length midptlist))
              (setq mindex 0)
              (setq mflag 0)
              (repeat miptlistlen 
                (setq 1midpt (nth mindex midptlist))
                (if 
                  (or 
                    (and (= (rtos (car 1midpt) 2 2) (rtos (car rsoff1sp) 2 2)) 
                         (= (rtos (cadr 1midpt) 2 2) (rtos (cadr rsoff1sp) 2 2))
                    )
                    (and (= (rtos (car 1midpt) 2 2) (rtos (car rsoff1ep) 2 2)) 
                         (= (rtos (cadr rsoff1ep) 2 2) (rtos (cadr 1midpt) 2 2))
                    )
                  )
                  (progn 
                    (setq mflag (+ mflag 1))
                  )
                  (progn 
                  )
                )
                (setq mindex (+ mindex 1))
              )
              (if (= mflag 0) 
                (progn 
                  (entdel (vlax-vla-object->ename rsoff1))
                  (setq rsoff1 (car 
                                 (vlax-safearray->list 
                                   (vlax-variant-value 
                                     (vlax-invoke-method rs1 
                                                         'Offset
                                                         (* (/ widthconjecture 2) -1)
                                     )
                                   )
                                 )
                               )
                  )
                  (entdel (vlax-vla-object->ename rs1))
                )
                (progn 
                  (entdel (vlax-vla-object->ename rs1))
                )
              )
              (ssadd (vlax-vla-object->ename rsoff1) mss)
              (vlax-for x (vla-get-hyperlinks rsoff1) (vla-delete x))
              (vla-add (vlax-get-property rsoff1 'Hyperlinks) 
                       (vl-princ-to-string widthconjecture)
              )
              (setq rsindex (+ rsindex 1))
            )
          )
        )
        (setq index (+ index 1))
      )
      (setq newmss (ssadd))
      (setq mindex 0)
      (repeat (sslength mss) 
        (setq m1 (ssname mss mindex))
        ;(princ m1)
        (if (entget m1) 
          (progn 
            (ssadd m1 newmss)
          )
        )
        (setq mindex (+ mindex 1))
      )
      (sssetfirst nil newmss)
      (setq oss (ssadd))
      (setq entl (entlast))
      (command "_pedit" "_M" newmss "" "J" "0" "")
      (while (setq ent (entnext entl)) 
        (ssadd ent oss)
        (setq entl ent)
      )
      (sssetfirst nil oss)
    
      (setq ossl (sslength oss))
      (setq oindex 0)
      (repeat ossl 
        (setq oent (ssname oss oindex))
        (setq oobj (vlax-ename->vla-object oent))
        (vlax-for each (vlax-get-property oobj 'Hyperlinks) 
          (setq hyp_txt (strcat (vla-get-url each)))
        )
        (vlax-put-property oobj 'constantwidth (atoi hyp_txt))
        (vlax-for x (vla-get-hyperlinks oobj) (vla-delete x))
        (setq olen (vlax-get-property oobj 'length))
        (setq resultformula (strcat resultformula 
                                    (if (= oindex 0) "" " + ")
                                    (vl-princ-to-string olen)
                            )
        )
        (setq resultsum (+ resultsum olen))
        (setq oindex (+ oindex 1))
      )
    
      (princ "\n hatches count = ")
      (princ (sslength ss))
      (princ "\n plines count - ")
      (princ oindex)
      (princ "\n total lenght of you selected")
      (princ "\n ")
      (princ resultformula)
      (princ " = ")
      (princ resultsum)
      (command "erase" rss "")
      (command "erase" pss "")
      (if (= (sslength ss) oindex)
        (progn
          (setq deleteuseranswer (getstring "\n The number of hatches and polylines is the same. Are you sure you want to delete the original hatch? (SpaceBar or AnyKey - Yes / N - No)"))
          (if (= deleteuseranswer nil)
            (setq deleteuseranswer "Y")
            (setq deleteuseranswer (strcase deleteuseranswer))
          )
          (if (/= deleteuseranswer "N")
            (command "erase" ss "")
          )
        )
        (progn
          (princ "\n The number of hatches and polylines does not match. There may be a problem, so please check manually.")
        )
      )
      (sssetfirst nil oss)
    )
    (progn
      (princ "\n There are no hatches in the selection set. Please try again.")
    )
  )

  (setvar 'cmdecho oldcmdecho)
  (setvar 'peditaccept oldpeditaccept)
  (vla-EndUndoMark thisdrawing)
  (princ)
)

This code works in AutoCAD, but the polylines are created in 2 layers (overlay) on top of the hatching, the hatching remains under these polylines. Is it possible to fix it?

And the request is not output to the command line, and there is no way to remove the hatches...
The number of hatches and polylines is the same. Are you sure you want to delete the original hatch?
(SpaceBar or AnyKey - Yes / N - No)"))

that function is not designed to be complex.

I use just simple basic command "erase" : (command "erase" selectionsetname).

If this basic command doesn't work,

it's usually because your CAD language is not English. as far as I know.

It is possible that other basic commands, "_pedit" or "_.hatchgenerateboundary" used in this code are working.

so you can edit "erase" with "_.erase" or "_erase". it will work i think

+ And I modified it can be deleted even if the number is not the same.

; HCEN - 2023.09.12 exceed
; Draw CenterLine in hatch (straight feature or elbow feature shape)
; for structural member systems, trays, piping, ducts, etc.,
;
;  This routine requires that the two line segments have the same length 
; and that length must be the shortest length.
; Straight, 90 degree elbow, 45 degree elbow, 30 degree elbow, etc. 
; Tilted cuts or odd shapes are not supported.
;  If the r value of the elbow is small and smaller than the two line 
; segment values above, an error may occur.
;
; updated 
; - Tested in autocad 2023 and zwcad 2022.
; - color inherit & delete original hatches option. (by user input)
; - "erase" -> "_.erase"

(defun C:HCEN (/ *error* thisdrawing util mspace myline index entl ent pss ss pssl 
               resultformula resultsum pent pobj ptype plength plist pclosed plistlen 
               pindex distlist p1 p2 pdist distlistlen dindex memorydist 
               widthconjecture 1dist resultlen rss breakptlist breakp1 breakp2 bpllen 
               bpindex bplistlen eobjlist eobjlistlen eindex remainlist 1obj 1objtype 
               1objsp 1objep bindex rssflag b1 rsslen rsindex rsofflist rs1 rsoff1 
               rsoff2 midptlist midpt rsoff1sp rsoff1ep mindex mflag 1midpt x delindex 
               delrss mss newmss m1 oss ossl oindex oent oobj each hyp_txt ssindex 
               ssslen colorlist sssindex sscolor ssent
               coloruseranswer deleteuseranswer
              ) 
  (vl-load-com)
  (setq thisdrawing (vla-get-activedocument (vlax-get-acad-object)))
  (defun *error* (msg) 
    (if (/= msg "Function cancelled") 
      (princ (strcat "\nError: " msg))
    )
    (setvar 'cmdecho oldcmdecho)
    (setvar 'peditaccept oldpeditaccept)
    (vla-EndUndoMark thisdrawing)
    (princ)
  )

  ;; Round Multiple  -  Lee Mac
  ;; Rounds 'n' to the nearest multiple of 'm'
  (defun LM:roundm (n m) 
    (* m (fix ((if (minusp n) - +) (/ n (float m)) 0.5)))
  )
  ;; Round To  -  Lee Mac
  ;; Rounds 'n' to 'p' decimal places
  (defun LM:roundto (n p) 
    (LM:roundm n (expt 10.0 (- p)))
  )
  (vla-EndUndoMark thisdrawing)
  (vla-startundomark thisdrawing)
  (setq oldpeditaccept 0)
  (setq oldpeditaccept (getvar 'peditaccept))
  (setq oldcmdecho 1)
  (setq oldcmdecho (getvar 'cmdecho))
  (setvar 'peditaccept 1)
  (setvar 'cmdecho 0)

  (setq util (vla-get-utility thisdrawing))
  (setq mspace (vla-get-modelspace thisdrawing))

  (if (setq entl (entlast)) 
    (progn 
      (setq entl (entlast))
    )
    (progn 
      (setq myline (vla-addline mspace 
                                (vlax-3d-point (list 0 0 0))
                                (vlax-3d-point (list 1 1 1))
                   )
      )
      (setq entl (entlast))
    )
  )
  (setq pss (ssadd))
  (princ "\n Select Hatches : ")
  (if (setq ss (ssget '((0 . "HATCH"))))
    (progn
      (setq ssslen (sslength ss))
      (setq colorlist '())
      (setq sssindex 0)
      (setq coloruseranswer (getstring "\n Do you want to inherit the color of the hatch to the polyline? (Space Bar or any key - Yes / N - Current Color"))
      (if (= coloruseranswer nil)
        (setq coloruseranswer "Y")
        (setq coloruseranswer (strcase coloruseranswer))
      )
      (repeat ssslen 
        (setq sssent (ssname ss sssindex))
        (setq sscolor (vlax-get-property 
                        (vlax-get-property (vlax-ename->vla-object sssent) 'truecolor)
                        'colorindex
                      )
        )
        ;(princ sscolor)
        (princ "\n")
        (command "_.hatchgenerateboundary" sssent "")
        (if (/= coloruseranswer "N")
          (vlax-put-property (vlax-ename->vla-object (entlast)) 'color sscolor)
        )
        (setq sssindex (+ sssindex 1))
      )
    
      (setq ssindex 0)
      (while (setq ent (entnext entl)) 
        (ssadd ent pss)
        (if (= ssindex 0) 
          (progn 
            (if (/= myline nil) 
              (vla-delete myline)
            )
          )
        )
        (setq entl ent)
        (setq ssindex (+ ssindex 1))
      )
      (sssetfirst nil pss)
      (setq pssl (sslength pss))
      (setq index 0)
      (setq resultformula "")
      (setq resultsum 0)
      (setq mss (ssadd))
    
      (repeat pssl 
        (setq pent (ssname pss index))
        (setq pobj (vlax-ename->vla-object pent))
        (setq ptype (vlax-get-property pobj 'entityname))
        (setq plength (vlax-get-property pobj 'length))
        (setq plist (vlax-safearray->list 
                      (vlax-variant-value (vlax-get-property pobj 'coordinates))
                    )
        )
        (setq pclosed (vlax-get-property pobj 'closed))
        (if (= pclosed :vlax-true) 
          (progn 
            (setq plist (append plist (list (car plist) (cadr plist))))
          )
          (progn)
        )
        (setq plistlen (length plist))
        (setq pindex 0)
        (setq distlist '())
        (repeat (- (/ plistlen 2) 1) 
          (setq p1 (list (nth pindex plist) (nth (+ pindex 1) plist)))
          (setq p2 (list (nth (+ pindex 2) plist) (nth (+ pindex 3) plist)))
          (setq pdist (distance p1 p2))
          (setq distlist (cons pdist distlist))
          (setq pindex (+ pindex 2))
        )
    
        (setq sorteddistlist (vl-sort distlist '<))
        (setq distlistlen (length sorteddistlist))
        (setq dindex 0)
        (setq memorydist -1)
        (setq widthconjecture 0)
        (repeat distlistlen 
          (setq 1dist (nth dindex sorteddistlist))
          (if 
            (and (= widthconjecture 0) 
                 (= (vl-princ-to-string memorydist) (vl-princ-to-string 1dist))
            )
            (setq widthconjecture 1dist)
          )
          (setq memorydist 1dist)
          (setq dindex (+ dindex 1))
        )
        (if (= widthconjecture 0)
          (setq widthconjecture (car sorteddistlist))
        )
        (setq dindex 0)
        (setq pindex 0)
        (setq breakptlist '())
        (setq distlist (reverse distlist))
        (repeat distlistlen 
          (setq 1dist (nth dindex distlist))
          (if (= (lm:roundto widthconjecture 0) (lm:roundto 1dist 0)) 
            (progn 
              (setq breakp1 (list (nth pindex plist) (nth (+ pindex 1) plist)))
              (setq breakp2 (list (nth (+ pindex 2) plist) (nth (+ pindex 3) plist)))
              (setq breakptlist (cons (list breakp1 breakp2) breakptlist))
            )
          )
          (setq dindex (+ dindex 1))
          (setq pindex (+ pindex 2))
        )
        (setq bplistlen (length breakptlist))
        (setq eobjlist (vlax-safearray->list (vlax-variant-value (vla-explode pobj))))
        (entdel pent)
        (setq eobjlistlen (length eobjlist))
        (setq eindex 0)
        (setq remainlist '())
        (setq rss (ssadd))
    
        (repeat eobjlistlen 
          (setq 1obj (nth eindex eobjlist))
          (setq 1objtype (vlax-get-property 1obj 'entityname))
          (cond 
            ((= 1objtype "AcDbArc")
             (setq remainlist (cons 1obj remainlist))
             (ssadd (vlax-vla-object->ename 1obj) rss)
            )
            ((= 1objtype "AcDbLine")
             (setq 1objsp (vlax-safearray->list 
                            (vlax-variant-value (vlax-get-property 1obj 'startpoint))
                          )
             )
             (setq 1objep (vlax-safearray->list 
                            (vlax-variant-value (vlax-get-property 1obj 'endpoint))
                          )
             )
             (if (/= (lm:roundto (distance 1objsp 1objep) 0) 0) 
               (progn 
                 (setq bindex 0)
                 (setq rssflag 0)
                 (repeat bplistlen 
                   (setq b1 (nth bindex breakptlist))
                   (if 
                     (or 
                       (and 
                         (= (lm:roundto (car (car b1)) 0) (lm:roundto (car 1objsp) 0))
                         (= (lm:roundto (cadr (car b1)) 0) 
                            (lm:roundto (cadr 1objsp) 0)
                         )
                         (= (lm:roundto (car (cadr b1)) 0) (lm:roundto (car 1objep) 0))
                         (= (lm:roundto (cadr (cadr b1)) 0) 
                            (lm:roundto (cadr 1objep) 0)
                         )
                       )
                       (and 
                         (= (lm:roundto (car (car b1)) 0) (lm:roundto (car 1objep) 0))
                         (= (lm:roundto (cadr (car b1)) 0) 
                            (lm:roundto (cadr 1objep) 0)
                         )
                         (= (lm:roundto (car (cadr b1)) 0) (lm:roundto (car 1objsp) 0))
                         (= (lm:roundto (cadr (cadr b1)) 0) 
                            (lm:roundto (cadr 1objsp) 0)
                         )
                       )
                     )
                     (progn 
                       (setq rssflag (+ rssflag 1))
                     )
                     (progn 
                     )
                   )
                   (setq bindex (+ bindex 1))
                 )
                 (if (/= rssflag 0) 
                   (progn 
                     (entdel (vlax-vla-object->ename 1obj))
                   )
                   (progn 
                     (setq remainlist (cons 1obj remainlist))
                     (ssadd (vlax-vla-object->ename 1obj) rss)
                   )
                 )
               )
               (progn 
                 (entdel (vlax-vla-object->ename 1obj))
               )
             )
            )
            (t
            )
          )
          (setq eindex (+ eindex 1))
        )
        (setq rsslen 0)
        (if rss 
          (progn 
            (setq rsslen (sslength rss))
            (setq rsindex 0)
            (setq rsofflist '())
    
            (setq bindex 0)
            (setq midptlist '())
            (repeat bplistlen 
              (setq bp1 (nth bindex breakptlist))
              (setq midpt (polar (car bp1) 
                                 (angle (car bp1) (cadr bp1))
                                 (/ (distance (car bp1) (cadr bp1)) 2)
                          )
              )
              (setq midptlist (cons midpt midptlist))
              (setq bindex (+ bindex 1))
            )
            (repeat rsslen 
              (setq rs1 (vlax-ename->vla-object (ssname rss rsindex)))
              (setq rsoff1 (car 
                             (vlax-safearray->list 
                               (vlax-variant-value 
                                 (vlax-invoke-method rs1 
                                                     'Offset
                                                     (* (/ widthconjecture 2) 1)
                                 )
                               )
                             )
                           )
              )
              (setq rsoff1sp (vlax-safearray->list 
                               (vlax-variant-value 
                                 (vlax-get-property rsoff1 'startpoint)
                               )
                             )
              )
              (setq rsoff1ep (vlax-safearray->list 
                               (vlax-variant-value (vlax-get-property rsoff1 'endpoint))
                             )
              )
              (setq miptlistlen (length midptlist))
              (setq mindex 0)
              (setq mflag 0)
              (repeat miptlistlen 
                (setq 1midpt (nth mindex midptlist))
                (if 
                  (or 
                    (and (= (rtos (car 1midpt) 2 2) (rtos (car rsoff1sp) 2 2)) 
                         (= (rtos (cadr 1midpt) 2 2) (rtos (cadr rsoff1sp) 2 2))
                    )
                    (and (= (rtos (car 1midpt) 2 2) (rtos (car rsoff1ep) 2 2)) 
                         (= (rtos (cadr rsoff1ep) 2 2) (rtos (cadr 1midpt) 2 2))
                    )
                  )
                  (progn 
                    (setq mflag (+ mflag 1))
                  )
                  (progn 
                  )
                )
                (setq mindex (+ mindex 1))
              )
              (if (= mflag 0) 
                (progn 
                  (entdel (vlax-vla-object->ename rsoff1))
                  (setq rsoff1 (car 
                                 (vlax-safearray->list 
                                   (vlax-variant-value 
                                     (vlax-invoke-method rs1 
                                                         'Offset
                                                         (* (/ widthconjecture 2) -1)
                                     )
                                   )
                                 )
                               )
                  )
                  (entdel (vlax-vla-object->ename rs1))
                )
                (progn 
                  (entdel (vlax-vla-object->ename rs1))
                )
              )
              (ssadd (vlax-vla-object->ename rsoff1) mss)
              (vlax-for x (vla-get-hyperlinks rsoff1) (vla-delete x))
              (vla-add (vlax-get-property rsoff1 'Hyperlinks) 
                       (vl-princ-to-string widthconjecture)
              )
              (setq rsindex (+ rsindex 1))
            )
          )
        )
        (setq index (+ index 1))
      )
      (setq newmss (ssadd))
      (setq mindex 0)
      (repeat (sslength mss) 
        (setq m1 (ssname mss mindex))
        ;(princ m1)
        (if (entget m1) 
          (progn 
            (ssadd m1 newmss)
          )
        )
        (setq mindex (+ mindex 1))
      )
      (sssetfirst nil newmss)
      (setq oss (ssadd))
      (setq entl (entlast))
      (command "_.pedit" "_M" newmss "" "J" "0" "")
      (while (setq ent (entnext entl)) 
        (ssadd ent oss)
        (setq entl ent)
      )
      (sssetfirst nil oss)
    
      (setq ossl (sslength oss))
      (setq oindex 0)
      (repeat ossl 
        (setq oent (ssname oss oindex))
        (setq oobj (vlax-ename->vla-object oent))
        (vlax-for each (vlax-get-property oobj 'Hyperlinks) 
          (setq hyp_txt (strcat (vla-get-url each)))
        )
        (vlax-put-property oobj 'constantwidth (atoi hyp_txt))
        (vlax-for x (vla-get-hyperlinks oobj) (vla-delete x))
        (setq olen (vlax-get-property oobj 'length))
        (setq resultformula (strcat resultformula 
                                    (if (= oindex 0) "" " + ")
                                    (vl-princ-to-string olen)
                            )
        )
        (setq resultsum (+ resultsum olen))
        (setq oindex (+ oindex 1))
      )
    
      (princ "\n hatches count = ")
      (princ (sslength ss))
      (princ "\n plines count - ")
      (princ oindex)
      (princ "\n total lenght of you selected")
      (princ "\n ")
      (princ resultformula)
      (princ " = ")
      (princ resultsum)
      (command "_.erase" rss "")
      (command "_.erase" pss "")
      (if (= (sslength ss) oindex)
        (progn
          (princ "\n Complete. The number of hatches and polylines is the same.")
        )
        (progn
          (princ "\n The number of hatches and polylines does not match. There may be a problem, so please check manually.")
        )
      )
      (setq deleteuseranswer (getstring "\n Are you sure you want to delete the original hatch? (SpaceBar or AnyKey - Yes / N - No)"))
      (if (= deleteuseranswer nil)
        (setq deleteuseranswer "Y")
        (setq deleteuseranswer (strcase deleteuseranswer))
      )
      (if (/= deleteuseranswer "N")
        (command "_.erase" ss "")
      )
      
      (sssetfirst nil oss)
    )
    (progn
      (princ "\n There are no hatches in the selection set. Please try again.")
    )
  )

  (setvar 'cmdecho oldcmdecho)
  (setvar 'peditaccept oldpeditaccept)
  (vla-EndUndoMark thisdrawing)
  (princ)
)

Edited September 12, 2023 by exceed

September 12, 2023

exceed, thank you very much!

I will take your advice:
"It is possible that other basic commands, "_pedit" or "_.hatchgenerateboundary"
used in this code are working".

Sign In

Convert Hatching to Polyline

Recommended Posts

Steven P

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

SLW210

Steven P

Steven P

Posted Images

exceed

Nikon

Steven P

Nikon

SLW210

Steven P

Nikon

Nikon

exceed

Nikon

Join the conversation

SLW210

Steven P

Steven P

Tutorials

Forums

Activity