Очередной аналог flatten. Обсуждение

(defun kpblc-dwg-flatten (/
              *kpblc-activedoc*
              *error*
              selset
              mod_item
              _kpblc-error-catch
              _kpblc-layer-status-restore
              _kpblc-layer-status-save
              _kpblc-conv-selset-to-ename
              _kpblc-conv-ent-pline-vertex-to-wcs
              _kpblc-ent-conv-z-to-0
              _kpblc-ent-modify-autoregen
              _kpblc-conv-pointlist-to-variant
              _kpblc-conv-list-to-3dpoints
              _kpblc-conv-list-to-2dpoints
              _kpblc-conv-3d-to-2d
              _kpblc-conv-2d-to-3d
              )
  (defun *error* (msg)
    (_kpblc-layer-status-restore)
    (vla-endundomark *kpblc-activedoc*)
    (princ msg)
    (princ)
    ) ;_ end of defun
  (defun _kpblc-conv-list-to-3dpoints (lst / res)
    (cond
      ((not lst)
       nil
       )
      (t
       (setq res (cons (list (car lst)
                 (if (cadr lst)
                   (cadr lst)
                   0.
                   ) ;_ end of if
                 (if (caddr lst)
                   (caddr lst)
                   0.
                   ) ;_ end of if
                 ) ;_ end of list
               (_kpblc-conv-list-to-3dpoints (cdddr lst))
               ) ;_ end of cons
         ) ;_ end of setq
       )
      ) ;_ end of cond
    res
    ) ;_ end of defun
  (defun _kpblc-conv-list-to-2dpoints (lst / res)
    (cond
      ((not lst)
       nil
       )
      (t
       (setq res (cons (list (car lst)
                 (if (cadr lst)
                   (cadr lst)
                   0.
                   ) ;_ end of if
                 ) ;_ end of list
               (_kpblc-conv-list-to-2dpoints (cddr lst))
               ) ;_ end of cons
         ) ;_ end of setq
       )
      ) ;_ end of cond
    res
    ) ;_ end of defun
  (defun _kpblc-conv-pointlist-to-variant (point-list / safe_list result)
    (setq safe_list (vlax-make-safearray
              vlax-vbdouble
              (cons 0 (1- (length point-list)))
              ) ;_ end of vlax-make-safearray
      ) ;_ end of setq
    (setq result (vlax-safearray-fill safe_list point-list))
    (vlax-make-variant result)
    ) ;_ end of defun
  (defun _kpblc-conv-2d-to-3d (point)
    (list (car point)
      (cadr point)
      (if (caddr point)
        (caddr point)
        0.0
        ) ;_ end of if
      ) ;_ end of list
    ) ;_ end of defun
  (defun _kpblc-conv-3d-to-2d (point)
    (list (car point) (cadr point))
    ) ;_ end of defun
  (defun _kpblc-conv-ent-to-ename (ent_value)
    (cond
      ((= (type ent_value) 'vla-object) (vlax-vla-object->ename ent_value))
      ((= (type ent_value) 'ename) ent_value)
      ((= (type ent_value) 'list) (cdr (assoc -1 ent_value)))
      (t nil)
      ) ;_ end of cond
    ) ;_ end of defun
  (defun _kpblc-conv-ent-to-vla    (ent_value)
    (cond
      ((= (type ent_value) 'vla-object) ent_value)
      ((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
      ((= (type ent_value) 'list)
       (cond
     ((= (type (car ent_value)) 'ename)
      (vlax-ename->vla-object (car ent_value))
      )
     (t
      (if
        (not
          (vl-catch-all-error-p
        (vl-catch-all-apply
          (vlax-ename->vla-object (_kpblc-conv-ent-to-ename ent_value))
          ) ;_ end of VL-CATCH-ALL-APPLY
        ) ;_ end of VL-CATCH-ALL-ERROR-P
          ) ;_ end of not
         nil
         ) ;_ end of if
      )
     ) ;_ end of cond
       )
      (t nil)
      ) ;_ end of cond
    ) ;_ end of defun
  (defun _kpblc-ent-modify-autoregen (ent     bit        value
                      ext_regen     /        ent_list
                      old_dxf     new_dxf    layer_dxf70
                      )
    (setq ent (_kpblc-conv-ent-to-ename ent))
    (if    (not
      (and
        (or
          (= (strcase (cdr (assoc 0 (entget ent))) nil) "STYLE")
          (= (strcase (cdr (assoc 0 (entget ent))) nil) "DIMSTYLE")
          (= (strcase (cdr (assoc 0 (entget ent))) nil) "LAYER")
          ) ;_ end of or
        (= bit 100)
        ) ;_ end of and
      ) ;_ end of not
      (progn
    (setq ent_list (entget ent)
          new_dxf  (cons bit
                 (if (and (= bit 62) (= (type value) 'str))
                   (if (= (strcase value) "BYLAYER")
                 256
                 0
                 ) ;_ end of if
                   value
                   ) ;_ end of if
                 ) ;_ end of cons
          ) ;_ end of setq
    (if (not (equal new_dxf (setq old_dxf (assoc bit ent_list))))
      (progn
        (entmod (if    old_dxf
              (subst new_dxf old_dxf ent_list)
              (append ent_list (list new_dxf))
              ) ;_ end of if
            ) ;_ end of entmod
        (if    ent_regen
          (entupd ent)
          (redraw ent)
          ) ;_ end of if
        ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of progn
      ) ;_ end of if
    ent
    ) ;_ end of defun
  (defun _kpblc-ent-conv-z-to-0    (ent / new pt lst loc:transpoint selset)
    (defun loc:transpoint (point ent)
      (if (/= (cdr (assoc 210 (entget ent))) '(0. 0. 1.))
    (trans point ent 0)
    point
    ) ;_ end of if
      ) ;_ end of defun
    (cond
      ((member (cdr (assoc 0 (entget ent))) '("INSERT" "HATCH"))
       (_kpblc-ent-modify-autoregen
     ent
     10
     (list (cadr (assoc 10 (entget ent)))
           (caddr (assoc 10 (entget ent)))
           0.
           ) ;_ end of list
     nil
     ) ;_ end of _kpblc-ent-modify-autoregen
       )
      ((= (cdr (assoc 0 (entget ent))) "LINE")
       (foreach    item '(10 11)
     (setq pt (loc:transpoint (cdr (assoc item (entget ent))) ent))
     (_kpblc-ent-modify-autoregen
       ent
       item
       (list (car pt) (cadr pt) 0.)
       nil
       ) ;_ end of _kpblc-ent-modify-autoregen
     ) ;_ end of foreach
       )
      ((member (cdr (assoc 0 (entget ent))) '("CIRCLE" "ARC"))
       (setq pt (trans (cdr (assoc 10 (entget ent))) ent 0))
       (_kpblc-ent-modify-autoregen
     ent
     10
     (list (car pt) (cadr pt) 0.)
     nil
     ) ;_ end of _kpblc-ent-modify-autoregen
       )
      ((= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
       (setq lst (mapcar '_kpblc-conv-3d-to-2d
             (_kpblc-conv-ent-pline-vertex-to-wcs ent)
             ) ;_ end of mapcar
         ) ;_ end of setq
       (if (not (equal (cdr (assoc 210 (entget ent))) '(0. 0. 1.)))
     (progn
       (vla-put-coordinates
         (_kpblc-conv-ent-to-vla ent)
         (_kpblc-conv-pointlist-to-variant (apply 'append lst))
         ) ;_ end of vla-put-coordinates
       (_kpblc-ent-modify-autoregen ent 210 '(0. 0. 1.) nil)
       ) ;_ end of progn
     ) ;_ end of if
       (_kpblc-ent-modify-autoregen ent 38 0 nil)
       (_kpblc-ent-modify-autoregen ent 39 0 nil)
       )
      ((= (cdr (assoc 0 (entget ent))) "LEADER")
       (vla-put-coordinates
     (_kpblc-conv-ent-to-vla ent)
     (_kpblc-conv-pointlist-to-variant
       (apply
         'append
         (mapcar
           '_kpblc-conv-2d-to-3d
           (mapcar '_kpblc-conv-3d-to-2d
               (_kpblc-conv-list-to-3dpoints
             (vlax-safearray->list
               (vlax-variant-value
                 (vla-get-coordinates (_kpblc-conv-ent-to-vla ent))
                 ) ;_ end of vlax-variant-value
               ) ;_ end of vlax-safearray->list
             ) ;_ end of _KPBLC-CONV-LIST-TO-3DPOINTS
               ) ;_ end of mapcar
           ) ;_ end of mapcar
         ) ;_ end of apply
       ) ;_ end of _kpblc-conv-pointlist-to-variant
     ) ;_ end of vla-put-coordinates
       )
      ((= (cdr (assoc 0 (entget ent))) "TEXT")
       (setq pt (loc:transpoint (cdr (_kpblc-get-text-point ent)) ent))
       (_kpblc-ent-modify-autoregen ent 10 (list (car pt) (cadr pt) 0.) nil)
       )
      ((= (cdr (assoc 0 (entget ent))) "MTEXT")
       (setq pt (loc:transpoint (cdr (_kpblc-get-text-point ent)) ent))
       (_kpblc-ent-modify-autoregen ent 10 (list (car pt) (cadr pt) 0.) nil)
       )
      ((= (cdr (assoc 0 (entget ent))) "DIMENSION")
       (foreach    item '(10 11 12 13 14 15 16)
     (if (cdr (assoc item (entget ent)))
       (progn
         (setq pt (loc:transpoint (cdr (assoc item (entget ent))) ent))
         (_kpblc-ent-modify-autoregen
           ent
           item
           (list (car pt) (cadr pt) 0.)
           nil
           ) ;_ end of _kpblc-ent-modify-autoregen
         ) ;_ end of progn
       ) ;_ end of if
     ) ;_ end of foreach
       )
      ((= (cdr (assoc 0 (entget ent))) "3DFACE")
       ;; Для 3DFACE преобразование попробуем не проводить
       (vla-addlightweightpolyline
     (vla-objectidtoobject
       *kpblc-activedoc*
       (vla-get-ownerid (vlax-ename->vla-object ent))
       ) ;_ end of vla-ObjectIDToObject
     (_kpblc-conv-pointlist-to-variant
       (apply 'append
          (mapcar
            '_kpblc-conv-3d-to-2d
            (mapcar 'cdr
                (vl-remove-if-not
                  '(lambda (x) (member (car x) '(10 11 12 13)))
                  (entget ent)
                  ) ;_ end of vl-remove-if-not
                ) ;_ end of mapcar
            ) ;_ end of mapcar
          ) ;_ end of apply
       ) ;_ end of _kpblc-conv-pointlist-to-variant
     ) ;_ end of vla-addlightweightpolyline
       (_kpblc-ent-properties-copy
     (_kpblc-conv-ent-to-vla ent)
     (_kpblc-conv-ent-to-vla (entlast))
     ) ;_ end of _kpblc-ent-properties-copy
       (entdel ent)
       (setq ent (entlast))
       (_kpblc-ent-modify-autoregen ent 70 1 t)
       )
      ) ;_ end of cond
    (_kpblc-ent-modify-autoregen ent 210 (list 0. 0. 1.) nil)
    ent
    ) ;_ end of defun
  (defun _kpblc-conv-ent-pline-vertex-to-wcs (ent / elevation normal)
    (setq elevation (cdr (assoc 38 (entget ent)))
      normal    (cdr (assoc 210 (entget ent)))
      ) ;_ end of setq
    (mapcar '(lambda (x) (trans (list (cadr x) (caddr x) elevation) normal 0))
        (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent))
        ) ;_ end of mapcar
    ) ;_ end of defun
  (defun _kpblc-layer-status-restore (/ item)
    (if    *kpblc-list-layer-status*
      (progn
    (foreach item *kpblc-list-layer-status*
      (_kpblc-error-catch
        '(lambda ()
           (vla-put-freeze (car item) (cdr (assoc "freeze" (cdr item))))
           ) ;_ end of LAMBDA
        nil
        ) ;_ end of _kpblc-error-catch
      (_kpblc-error-catch
        '(lambda ()
           (vla-put-lock (car item) (cdr (assoc "lock" (cdr item))))
           ) ;_ end of LAMBDA
        nil
        ) ;_ end of _kpblc-error-catch
      ) ;_ end of foreach
    ) ;_ end of progn
      ) ;_ end of if
    (setq *kpblc-list-layer-status* nil)
    ) ;_ end of defun
  (defun _kpblc-layer-status-save (layers-on / item)
    (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))
                 ) ;_ end of list
               ) ;_ end of list
             ) ;_ end of append
        ) ;_ end of setq
      (if layers-on
    (progn
      (_kpblc-error-catch
        '(lambda ()
           (vla-put-freeze item :vlax-false)
           ) ;_ end of LAMBDA
        nil
        ) ;_ end of _KPBLC-ERROR-CATCH
      (vla-put-lock item :vlax-false)
      ) ;_ end of progn
    ) ;_ end of if
      ) ;_ end of vlax-for
    ) ;_ end of defun
  (defun _kpblc-error-catch
     (protected-function on-error-function / catch_error_result)
    (setq catch_error_result (vl-catch-all-apply protected-function))
    (if    (and (vl-catch-all-error-p catch_error_result)
         on-error-function
         ) ;_ end of and
      (apply on-error-function
         (list (vl-catch-all-error-message catch_error_result))
         ) ;_ end of APPLY
      catch_error_result
      ) ;_ end of if
    ) ;_ end of defun
  (defun _kpblc-conv-selset-to-ename (selset)
    (if    selset
      (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
      ) ;_ end of if
    ) ;_ end of defun
  (vl-load-com)
  (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
  (vla-startundomark *kpblc-activedoc*)
  (if (setq selset (ssget))
    (progn
      (_kpblc-layer-status-save t)
      (foreach item (_kpblc-conv-selset-to-ename selset)
    (setq mod_item (_kpblc-ent-conv-z-to-0 item))
    (if (vlax-property-available-p
          (_kpblc-conv-ent-to-vla mod_item)
          "thickness"
          ) ;_ end of vlax-property-available-p
      (vla-put-thickness (_kpblc-conv-ent-to-vla mod_item) 0.)
      ) ;_ end of if
    ) ;_ end of foreach
      (_kpblc-layer-status-restore)
      ;(setupdatedisplay t)
      ) ;_ end of progn
    ) ;_ end of if
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  ) ;_ end of defun