AutoCAD LISP 55

z0.lsp = обнуление координаты Z

;;;Обнуленеи координаты Z
;;;2018-02-08 Добавлено обнуление примитивов блоков, сплайнов
;;;2018-02-27 Обработка OLE объектов
(defun c:Z0 (/ ss *error* lst tmp j bl e1)
  (vl-load-com)
 (defun *error* (message / image_set)
        (while (> (getvar "CMDACTIVE") 0) (command))
        (or *kpblc-activedoc*
            (setq *kpblc-activedoc*
                   (vla-get-activedocument (vlax-get-acad-object))
            ) ;_ end of setq
        ) ;_ end of or
        (princ message)
        (foreach item *kpblc-list-layer-status*
          (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
        ) ;_ end of foreach
        (setq *kpblc-list-layer-status* nil)
        (kpblc-error-restore-sysvar)
        (vla-endundomark *kpblc-activedoc*)
        (princ)
      )
  (or *kpblc-activedoc*
    (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
      )
  (kpblc-error-save-sysvar
    (list
      '("osmode")
      '("CLAYER")
      '("DIMZIN")
      '("QACountS" 0)
      '("CMDECHO" 0)
      '("EXPERT" 5)
      '("highlight" 1)
      '("cecolor" "bylayer")
      '("CELTYPE" "bylayer")
      '("limcheck" 0)
      '("pickstyle" 0)
      '("ANGBASE" 0)
      '("ANGDIR" 0)
      '("UCSFOLLOW" 0)
      '("LUNITS" 2)
      '("AUNITS" 1)
      (list "LUPREC" (max 2 (getvar "LUPREC")))
      (list "AUPREC" (max 3 (getvar "AUPREC")))
      (list "ucsicon" (getvar "ucsicon"))
    )
  )
  (vla-startundomark *kpblc-activedoc*)
  (mip:layer-status-save)
  (SETQ SS NIL)
  (princ "\nВыберите объеты или ENTER - весь чертеж")
  (if (null
    (setq SS (ssget '((-4 . "<NOT") (0 . "3DSOLID,OLE2FRAME") (-4 . "NOT>"))))
      )
    (progn
      (if (and (setq ss (ssget "_X" '((0 . "DIMENSION"))))
           (setq lst (lib:conv-pickset-to-list ss))
      )
    (progn
      (setq ss nil)
      (foreach item    lst
        (setq ss (entget item))
        (mapcar '(lambda (x)
               (if (setq tmp (assoc x ss))
             (setq ss (subst (list x (cadr tmp) (caddr tmp) 0.0)
                     tmp
                     ss
                  )
             )
               )
             )
            '(10 11 12 13 14) ;_Точки
        )
            (setq ss (entmod ss))
      )
    )
      )
      (setq SS (ssget "_X"
              (list
            '(-4 . "<NOT")
            '(0 . "3DSOLID,OLE2FRAME")
            '(-4 . "NOT>")
            (cons 410 (getvar "CTAB"))
              )
           )
      )
    )
  )
  (if SS
    (progn
      (setq j 0)
      (setq lst(lib:conv-pickset-to-list ss))
      (bg:progress-init "Обрабатываю: " (length lst))
      (foreach item lst
        (setq j (1+ j))
        (bg:progress j)
        ((lambda ( ed )
        (mapcar '(lambda (x)
               (if (setq tmp (assoc x ed))
             (if (numberp (cdr tmp))
              (setq ed (subst (cons x 0)
                     tmp
                     ed
                  )
                )
             
             (setq ed (subst (list x (cadr tmp) (caddr tmp) 0.0)
                     tmp
                     ed
                  )
             )
               )
               )
             )
            '(10 11 12 13 14 38 39)
        )
            (foreach z ed ;_spline
              (if (member (car z) '(10 11))
                (setq ed (subst (list (car z) (cadr z) (caddr z) 0.0)
                     z
                     ed
                  )
             )
                )
              )
        (entmod ed)
           )
          (entget item)
          )
        (if (and (= (cdr(assoc 0 (entget item))) "INSERT")
                 (= (cdr(assoc 66 (entget item))) 1)
                 )
          (while (and(setq item(entnext item))(/=(cdr(assoc 0(entget item))) "SEQEND"))
            ((lambda ( ed )
        (mapcar '(lambda (x)
               (if (setq tmp (assoc x ed))
             (if (numberp (cdr tmp))
              (setq ed (subst (cons x 0)
                     tmp
                     ed
                  )
                )
             
             (setq ed (subst (list x (cadr tmp) (caddr tmp) 0.0)
                     tmp
                     ed
                  )
             )
               )
               )
             )
            '(10 11 12 13 14 38 39)
        )
            (foreach z ed ;_spline
              (if (member (car z) '(10 11))
                (setq ed (subst (list (car z) (cadr z) (caddr z) 0.0)
                     z
                     ed
                  )
             )
                )
              )  
        (entmod ed)
           )
          (entget item)
          )
            )
          )
        )
       
      (bg:progress-clear)
      (princ (strcat "\n" (rtos j 2 0)  " Objects Flattened."))
    )
  )
(setq bl (tblnext "block" 1))
  (while bl
    (setq e1 (cdr(assoc -2 bl)))
    (while (and e1 (not (member '(0 . "ENDBLK") (entget e1))))
      ((lambda ( ed )
        (mapcar '(lambda (x)
               (if (setq tmp (assoc x ed))
             (if (numberp (cdr tmp))
              (setq ed (subst (cons x 0)
                     tmp
                     ed
                  )
                )
             
             (setq ed (subst (list x (cadr tmp) (caddr tmp) 0.0)
                     tmp
                     ed
                  )
             )
               )
               )
             )
            '(10 11 12 13 14 38 39)
        )
         (foreach z ed ;_spline
              (if (member (car z) '(10 11))
                (setq ed (subst (list (car z) (cadr z) (caddr z) 0.0)
                     z
                     ed
                  )
             )
                )
              )  
        (entmod ed)
           )
          (entget e1)
          )
      (setq e1 (entnext e1))
        )
    (setq bl (tblnext "block"))
      )
  (vla-endundomark *kpblc-activedoc*)
  (kpblc-error-restore-sysvar)
  (mip:layer-status-restore)
  (vl-cmdf "_.REGENALL")
  (princ)
)
  (defun mip:layer-status-restore ()
    (_kpblc-layer-status-restore)
    ) ;_ end of defun

  (defun mip:layer-status-save ()
      (_kpblc-layer-status-save nil)
    );_ end of defun

(defun bg:progress-init (msg maxlen)
  ;;; msg - сообщение или пустая строка
  ;;; maxlen - максимальное количество
  (or *BG:PROGRESS:OM* (setq *BG:PROGRESS:OM* (getvar "MODEMACRO")))
  (setq *BG:PROGRESS:MSG* (vl-princ-to-string msg))
  (setq *BG:PROGRESS:MAXLEN* maxlen)
  (setq *BG:PROGRESS:LPS* '-1)(princ)
  )
(defun bg:progress ( currvalue / persent str1 count)
  (if *BG:PROGRESS:MAXLEN*
    (progn
  (setq persent (fix (/ currvalue 0.01 *BG:PROGRESS:MAXLEN*)))
  ;;;Каждые 5 %
  (setq count (fix(* persent 0.2)))
  (setq str1 "")
  (if (/= count *BG:PROGRESS:LPS*)
    (progn
      ;;(setq str1 "")
      (repeat persent (setq str1 (strcat str1 "|")))
      )
    )
       ;;; currvalue - текущее значение
      (setvar "MODEMACRO"
              (strcat (vl-princ-to-string *BG:PROGRESS:MSG*)
                      " "
                      (itoa persent)
                      " % "
                      str1
                      )
              )
      (setq *BG:PROGRESS:LPS* persent)
  )
    )
  )
    
(defun bg:progress-clear ()
  (setq *BG:PROGRESS:MSG* nil)
  (setq *BG:PROGRESS:MAXLEN* nil)
  (setq *BG:PROGRESS:LPS* nil)
  (setvar "MODEMACRO" (vl-princ-to-string *BG:PROGRESS:OM*))
  ;;;(vla-regen (vla-get-activedocument (vlax-get-acad-object)) acactiveviewport)
  (princ)
  )
(defun lib:conv-pickset-to-list (value / item lst)
       (repeat (setq item (sslength value)) ;_ end setq
         (setq lst (cons (ssname value (setq item (1- item))) lst))
         ) ;_ end repeat

  lst
  ) ;_ end of defun
(defun kpblc-error-save-sysvar (sysvar-list)
  (foreach item  sysvar-list
    (setq *kpblc-sysvar-list*
     (cons (list (car item) (getvar (car item))) *kpblc-sysvar-list*))
    (if  (cadr item)(_kpblc-sysvar-set (car item) (cadr item))) ;_ end of if
    ) ;_ end of foreach
  ) ;_ end of defun
(defun _kpblc-sysvar-set (sysvar value)
  (if (getvar sysvar)         ; Такая переменная есть вообще или нет?
    (if   (and (= value "")(wcmatch (strcase sysvar t) "dim*")) ;_ end of and
      (setvar sysvar ".")
      (vl-catch-all-apply 'setvar (list sysvar value))
      ) ;_ end of if
    ) ;_ end of if
  (getvar sysvar)
  ) ;_ end of defun
(defun kpblc-error-restore-sysvar ()
  (if *kpblc-sysvar-list*
    (foreach item *kpblc-sysvar-list* (_kpblc-sysvar-set (car item) (cadr item))))
  (setq *kpblc-sysvar-list* nil)(gc)) ;_ end of defun
(defun _kpblc-layer-status-save (layers-on / item)
      (or *kpblc-activedoc*
          (setq *kpblc-activedoc*
                 (vla-get-activedocument
                   (vlax-get-acad-object)
                 ) ;_ end of vla-get-activedocument
          ) ;_ end of setq
      ) ;_ end of or
      (if *kpblc-list-layer-status*
        (setq *kpblc-list-layer-status* nil)
      ) ;_ end of if
      (vlax-for item (vla-get-layers *kpblc-activedoc*)
        (setq *kpblc-list-layer-status*
               (append *kpblc-list-layer-status*
                       (list
                         (list item
                               (cons "freeze" (vla-get-freeze item))
                               (cons "lock" (vla-get-lock item))
                               (cons "on" (vla-get-layeron item))
                         ) ;_ end of list
                       ) ;_ end of list
               ) ;_ end of append
        ) ;_ end of setq
        (if layers-on
          (progn
            (vla-put-layeron item :vlax-true)
          ) ;_ end of if
        ) ;_ end of progn
        (vla-put-lock item :vlax-false)
        (if (not (equal (vla-get-activelayer *kpblc-activedoc*) item))
          (vla-put-freeze item :vlax-false)
        ) ;_ end of if
      ) ;_ end of vlax-for
    ) ;_ end of defun
(defun _kpblc-layer-status-restore (/ item)
      (or *kpblc-activedoc*
          (setq *kpblc-activedoc*
                 (vla-get-activedocument
                   (vlax-get-acad-object)
                 ) ;_ end of vla-get-activedocument
          ) ;_ end of setq
      ) ;_ end of or
      (if *kpblc-list-layer-status*
        (progn
          (foreach item *kpblc-list-layer-status*
            (if (vlax-write-enabled-p (car item))
              (progn
                (VL-CATCH-ALL-APPLY '(lambda()
                (vla-put-layeron
                  (car item)
                  (cdr (assoc "on" (cdr item)))
                ) ;_ end of vla-put-layeron
                (vla-put-lock
                  (car item)
                  (cdr (assoc "lock" (cdr item)))
                ) ;_ end of vla-put-lock
                (if (not (equal (strcase (getvar "CLAYER"))
                                (strcase (vla-get-name (car item)))
                         ) ;_ end of equal
                    ) ;_ end of not
                  (vla-put-freeze
                    (car item)
                    (cdr (assoc "freeze" (cdr item)))
                  ) ;_ end of vla-put-freeze
                ) ;_ end of if
                                       )
                  )
              ) ;_ end of progn
            ) ;_ end of if
          ) ;_ end of foreach
          (setq *kpblc-list-layer-status* nil)
        ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of defun
(defun bg:massoc (key alist)
  ;;;lib:massoc mip_lib.lsp
  (mapcar 'cdr (vl-remove-if-not (function (lambda (x) (= key (car x)))) alist)))

        (princ "\nhttp://forum.dwg.ru/showthread.php?p=1084041#post1084041")
    (princ "\nType Z0 in command line ver.2018-02-27")(princ)

z0.lsp = обнуление координаты Z