Author Topic: FLATTEN help required  (Read 940 times)

0 Members and 1 Guest are viewing this topic.

w64bit

  • Newt
  • Posts: 78
FLATTEN help required
« on: March 01, 2022, 03:11:58 PM »
Hi,
I tried to make a slim lisp for flattening, from different codes available on forums.
Can someone please help to give a look over it to see if it's something wrong and to slim it more and to add the code for:
- flattening REGION;
- changing OLE Z coordinate to zero.
I know that there are specific codes for specific entities but the lisp is small in this way.
Thank you.

Code: [Select]
(defun C:ZERO (/   zeroz   ss1     ss1len  i       numchg
                   ename   elist   etype   vrt     crz
              )

;Function to change Z coordinate to 0
(defun zeroz (key zelist / oplist nplist)
  (setq oplist (assoc key zelist)
        nplist (reverse (append '(0.0) (cdr (reverse oplist))))
        zelist (subst nplist oplist zelist)
  )
  (entmod zelist)
)

;Initialization
(setvar  "CMDECHO" 0)                  ;no prompts and inputs displayed on command line
(command ".UCS" "World")               ;set World UCS
(command ".UNDO" "Group")              ;start undo group

;Get input
(setq ss1 (ssget "X"))                 ;select all entities in database

  ;*initialize variables
  (setq ss1len (sslength ss1)          ;length of selection set
        i      0                       ;loop counter
        numchg 0                       ;number changed counter
  )                                    ;setq

  ;*do the work
  (prompt "\nZERO Working ..")
  (while (< i ss1len)                  ;while more members in the SS
    (if (= 0 (rem i 500))
      (prompt ".")
    )
    (setq ename (ssname ss1 i)         ;entity name
          elist (entget ename)         ;entity data list
          etype (cdr (assoc 0 elist))  ;entity type
    )

    ;change each POLYLINE vertex Z coordinate to 0
    ;code provided by Vladimir Livshiz, 1998_10_09
    (if (= etype "POLYLINE")
      (progn
        (setq vrt ename)
        (while (not (equal (cdr (assoc 0 (entget vrt))) "SEQEND"))
          (setq elist (entget (entnext vrt)))
          (setq crz   (cadddr (assoc 10 elist)))
          (if (/= crz 0)
            (progn
              (zeroz 10 elist)
              (entupd ename)
            )
          )
          (setq vrt (cdr (assoc -1 elist)))
        )
      )
    )

    ;special handling for LWPOLYLINE
    ;code provided by Mark Middlebrook
    (if (= etype "LWPOLYLINE")
      (progn
        (setq elist  (subst (cons 38 0.0) (assoc 38 elist) elist)
              numchg (1+ numchg)
        )
        (entmod elist)
      )
    )

  (setq i (1+ i))                      ;next entity

  )

  ;ZERO the rest
  ;code provided by Jonathan Handojo, 2022_02_23
  (repeat (setq i (sslength ss1))
    (entmod
      (mapcar
        (function
          (lambda (a)
            (if
              (member (car a)
                '(10 11 12 13 14 15 16 17 18
                  20 21 22 23 24 25 26 27 28
                  30 31 32 33 34 35 36 37)
              )
              (list (car a) (cadr a) (caddr a) 0.0)
              a
            )
          )
        )
        (entget (ssname ss1 (setq i (1- i))))
      )
    )
  )

(command "CHANGE" "ALL" "" "P" "T" 0 "")

(terpri)
(if (ssget "X" '((0 . "INSERT") (66 . 1)))(command "ATTSYNC" "N" "*"))
(command "REGEN")

(command ".UNDO" "End")                ;end undo group

(terpri)
(prompt "\nZERO Done.")
(terpri)

(princ)

)

PM

  • Guest
Re: FLATTEN help required
« Reply #1 on: March 13, 2022, 05:00:34 AM »
I use this code

Code - Auto/Visual Lisp: [Select]
  1. (defun c:Z-coord ( )
  2. (princ "\nATTENTION !!!  Do NOT use this routine on a 3D-drawing !!!")
  3. (initget "y Y n N")
  4. (setq sure (getkword "\nAre you sure you want to move all Z-co&#1616;ordinates to 0.000 ? (Y/N) <N>:"))
  5. (setq sure (strcase sure))
  6. (if (= sure "")
  7.     (setq sure "N")
  8. )
  9. (if (= sure "Y")
  10.     (progn
  11.         (initget "y Y n N")
  12.         (setq reallysure (getkword "\nAre you REALLY sure ? (Y/N) <N>: "))
  13.         (setq reallysure (strcase reallysure))
  14.         (if (= reallysure "")
  15.             (setq reallysure "N")
  16. )   )   )
  17. (if (= reallysure "Y")
  18.     (progn
  19.         (setq zasnw 0.0)
  20.         (if (setq selectie (ssget "x"))
  21.             (progn
  22.                 (setq aantent (sslength selectie))
  23.                 (setq teller 0)
  24.                 (while (< teller aantent)
  25.                     (setq startlijst nill)
  26.                     (setq endlijst nill)
  27.                     (setq elevlijst nill)
  28.                     (setq diktelijst nill)
  29.                     (setq volg nill)
  30.                     (setq entnaam (ssname selectie teller))
  31.                     (setq teller (1+ teller))
  32.                     (setq entlijst (entget entnaam))
  33.                     (setq startlijst (assoc 10 entlijst))
  34.                     (setq endlijst (assoc 11 entlijst))
  35.                     (setq elevlijst (assoc 38 entlijst))
  36.                     (setq diktelijst (assoc 39 entlijst))
  37.                     (setq volg (cdr (assoc 66 entlijst)))
  38.                     (setq xstart (cadr startlijst))
  39.                     (setq ystart (caddr startlijst))
  40.                     (setq xend (cadr endlijst))
  41.                     (setq yend (caddr endlijst))
  42.                     (setq startnw (list '10 xstart ystart zasnw))
  43.                     (setq endnw (list '11 xend yend zasnw))
  44.                     (setq elev (cons '38 zasnw))
  45.                     (setq dikte (cons '39 zasnw))
  46.                     (setq entlijst (subst startnw startlijst entlijst))
  47.                     (entmod entlijst)
  48.                     (entupd entnaam)
  49.                     (if (not (= endlijst nil))
  50.                         (progn
  51.                             (setq entlijst (subst endnw endlijst entlijst))
  52.                             (entmod entlijst)
  53.                             (entupd entnaam)
  54.                     )   )
  55.                     (if (not (= elevlijst nil))
  56.                         (progn
  57.                             (setq entlijst (subst elev elevlijst entlijst))
  58.                             (entmod entlijst)
  59.                             (entupd entnaam)
  60.                     )   )
  61.                     (if (not (= diktelijst nil))
  62.                         (progn
  63.                             (setq entlijst (subst dikte diktelijst entlijst))
  64.                             (entmod entlijst)
  65.                             (entupd entnaam)
  66.                     )   )
  67.                     (if (= volg 1)
  68.                         (progn
  69.                             (setq entnaam1 (entnext entnaam))
  70.                             (while (= volg 1)
  71.                                 (setq startlijst nill)
  72.                                 (setq endlijst nill)
  73.                                 (setq elevlijst nill)
  74.                                 (setq diktelijst nill)
  75.                                 (setq volg nill)
  76.                                 (setq entlijst (entget entnaam1))
  77.                                 (setq startlijst (assoc 10 entlijst))
  78.                                 (setq endlijst (assoc 11 entlijst))
  79.                                 (setq elevlijst (assoc 38 entlijst))
  80.                                 (setq diktelijst (assoc 39 entlijst))
  81.                                 (setq volg (cdr (assoc 66 entlijst)))
  82.                                 (if (not (= startlijst nil))
  83.                                     (progn
  84.                                         (setq xstart (cadr startlijst))
  85.                                         (setq ystart (caddr startlijst))
  86.                                         (setq startnw (list '10 xstart ystart zasnw))
  87.                                         (setq entlijst (subst startnw startlijst entlijst))
  88.                                         (entmod entlijst)
  89.                                         (entupd entnaam1)
  90.                                 )   )
  91.                                 (if (not (= endlijst nil))
  92.                                     (progn
  93.                                         (setq xend (cadr startlijst))
  94.                                         (setq yend (caddr startlijst))
  95.                                         (setq endnw (list '10 xend yend zasnw))
  96.                                         (setq entlijst (subst endnw endlijst entlijst))
  97.                                         (entmod entlijst)
  98.                                         (entupd entnaam1)
  99.                                 )   )
  100.                                 (if (not (= elevlijst nil))
  101.                                     (progn
  102.                                         (setq entlijst (subst elev elevlijst entlijst))
  103.                                         (entmod entlijst)
  104.                                         (entupd entnaam1)
  105.                                 )   )
  106.                                 (if (not (= diktelijst nil))
  107.                                     (progn
  108.                                         (setq entlijst (subst dikte diktelijst entlijst))
  109.                                         (entmod entlijst)
  110.                                         (entupd entnaam1)
  111.                                 )   )
  112.                                 (if (= volg 1)
  113.                                     (setq entnaam1 (entnext entnaam1))
  114. )   )   )   )   )   )   )   )   )
  115. (setvar "attreq" 1)
  116. )
  117.  

w64bit

  • Newt
  • Posts: 78
Re: FLATTEN help required
« Reply #2 on: March 14, 2022, 10:14:14 AM »
Thank you, but your code does not add support for OLE and REGION.