(defun c:tbltoex ()
  (pl:export-to-excel)
) ;_ end of defun

(defun pl:export-to-excel (/ ccells csheet dat excel i k newbook torel wbooks wsheets next cols)
  (if (setq excel (vlax-get-or-create-object "Excel.Application"))
    (progn
      (setq wbooks  (vlax-get-property excel 'workbooks)
            newbook (vlax-invoke-method wbooks 'add 1)
            wsheets (vlax-get-property newbook 'worksheets)
            csheet  (vlax-get-property newbook 'activesheet)
      ) ;_ end of setq
      (while (setq dat (pl:get-tbl-data))
        (if next
          (setq torel  (cons csheet torel)
;;; csheet (vlax-invoke-method wsheets 'add nil csheet) ;_ при использовании этой строки, при закрытии Экселя - ошибка
                csheet (vlax-invoke-method wsheets 'add)
          ) ;_ end of setq
        ) ;_ end of if
        (setq ccells (vlax-get-property csheet 'cells)
              cols   (vlax-get-property csheet 'columns)
              i      0
        ) ;_ end of setq
        (foreach y dat
          (setq i (1+ i)
                k 0
          ) ;_ end of setq
          (foreach x y
            (setq k (1+ k))
            (pl:put-val-to-cell ccells i k x)
          ) ;_ end of foreach
        ) ;_ end of foreach
        (vlax-invoke-method cols 'autofit)
        (vlax-release-object cols)
        (vlax-release-object ccells)
        (setq next t)
      ) ;_ end of while
      (if torel
        (vlax-invoke-method (last torel) 'activate)
      ) ;_ end of if
      (if (= (vlax-get-property excel 'visible) :vlax-false)
        (vlax-put-property excel 'visible :vlax-true)
      ) ;_ end of if
      (foreach x (cons csheet
                       (if torel
                         (append torel (list wsheets newbook wbooks excel))
                         (list wsheets newbook wbooks excel)
                       ) ;_ end of if
                 ) ;_ end of cons
        (vlax-release-object x)
      ) ;_ end of foreach
    ) ;_ end of progn
    (alert "Не могу запустить Excel!")
  ) ;_ end of if
  (princ)
) ;_ end of defun

(defun pl:put-val-to-cell (ccells x y val / tmp brd form)
  (setq val (vl-string-trim " " val))
  (vlax-put-property
    (setq tmp (vlax-variant-value
                (vlax-get-property
                  ccells
                  'item
                  (vlax-make-variant x vlax-vbinteger)
                  (vlax-make-variant y vlax-vbinteger)
                ) ;_ end of vlax-get-property
              ) ;_ end of vlax-variant-value
    ) ;_ end of setq
    "Value2"
    (vlax-make-variant val vlax-vbvariant)
  ) ;_ end of vlax-put-property
  (setq brd (vlax-get-property tmp 'borders))
  (vlax-put-property brd 'colorindex (vlax-make-variant -4105 3))
  (if (= (type (setq form (pl:is-real-form val))) 'str)
    (vlax-put-property
      tmp
      'numberformat
      (vlax-make-variant (strcat "# ##0" form) 8)
    ) ;_ распознавание форматов
  ) ;_ end of if
  (vlax-release-object brd)
  (vlax-release-object tmp)
) ;_ end of defun

(defun pl:is-real-form (val)
  (cond ((not (= (vl-string-trim "0123456789.," val) "")) nil)
        ((= (vl-string-trim "0123456789" val) "") "")
        ((< 1
            (length (vl-remove-if-not
                      (function
                        (lambda (a)
                          (or (= a 44) (= a 46))
                        ) ;_ end of lambda
                      ) ;_ end of function
                      (vl-string->list val)
                    ) ;_ end of vl-remove-if-not
            ) ;_ end of length
         ) ;_ end of <
         nil
        )
        (t
         (vl-list->string
           (mapcar (function
                     (lambda (b)
                       (if (or (= b 44) (= b 46))
                         46
                         48
                       ) ;_ end of if
                     ) ;_ end of lambda
                   ) ;_ end of function
                   (vl-string->list (vl-string-left-trim "0123456789" val))
           ) ;_ end of mapcar
         ) ;_ end of vl-list->string
        )
  ) ;_ end of cond
) ;_ end of defun

(defun pl:get-tbl-ents (/ _box)
  (setq
    _box
     (vl-catch-all-apply
       (function
         (lambda (/ corn1 corn2)
           (if
             (and (setq corn1
                         (getpoint
                           "\ Tablonun kosesini goster <Exit>: "
                         ) ;_ end of getpoint
                  ) ;_ end of setq
                  (setq corn2
                         (getcorner
                           corn1
                           "\diagonal koseyi sec ve enter <Exit>: "
                         ) ;_ end of getcorner
                  ) ;_ end of setq
             ) ;_ end of and
              (list corn1 corn2)
           ) ;_ end of if
         ) ;_ end of lambda
       ) ;_ end of function
       nil
     ) ;_ end of vl-catch-all-apply
  ) ;_ end of setq
  (if (cond ((not _box) (princ "\nNo selection") nil)
            ((vl-catch-all-error-p _box)
             (princ (strcat "\n" (vl-catch-all-error-message _box)))
             nil
            )
            (t
             (setq _box (list (list (min (caar _box) (caadr _box))
                                    (max (cadar _box) (cadadr _box))
                              ) ;_ end of list
                              (list (max (caar _box) (caadr _box))
                                    (min (cadar _box) (cadadr _box))
                              ) ;_ end of list
                        ) ;_ end of list
             ) ;_ end of setq
            )
      ) ;_ end of cond
    (list _box
          (ssget "_C" (car _box) (cadr _box) '((0 . "LINE")))
          (ssget "_C" (car _box) (cadr _box) '((0 . "LWPOLYLINE")))
          (ssget "_C" (car _box) (cadr _box) '((0 . "TEXT")))
    ) ;_ end of list
  ) ;_ end of if
) ;_ end of defun

(defun pl:get-tbl-data (/ _sel _texts _lhrzn _lines _lvert _lwpl _modcol _modrow _mtx)
  (if (setq _texts (last (setq _sel (pl:get-tbl-ents))))
    (progn
      (setq _lines (cadr _sel)
            _lwpl  (caddr _sel)
            _sel   (car _sel)
      ) ;_ end of setq
      (if _lines
        (setq _lines (mapcar 'pl:extr-pnt-from-line (pl:entlst-from-ss _lines)))
      ) ;_ end of if
      (if _lwpl
        (setq _lwpl (apply 'append
                           (mapcar 'pl:lwpl-to-segments (pl:entlst-from-ss _lwpl))
                    ) ;_ end of apply
        ) ;_ end of setq
      ) ;_ end of if
      (if
        (and (setq _lines (append _lines _lwpl))
             (setq _lines (vl-remove-if-not
                            (function
                              (lambda (x)
                                (pl:is-point-in-bbox (pl:get-cen-pnts-2d x) _sel)
                              ) ;_ end of lambda
                            ) ;_ end of function
                            _lines
                          ) ;_ end of vl-remove-if-not
             ) ;_ end of setq
             (setq _lines (mapcar (function
                                    (lambda (x)
                                      (pl:near-orto x 3)
                                    ) ;_ end of lambda
                                  ) ;_ end of function
                                  _lines
                          ) ;_ end of mapcar
             ) ;_ end of setq
             (> (length
                  (setq _lvert (mapcar 'cdr
                                       (vl-remove-if
                                         (function
                                           (lambda (x)
                                             (or (not x)
                                                 (= (car x) 0)
                                             ) ;_ end of or
                                           ) ;_ end of lambda
                                         ) ;_ end of function
                                         _lines
                                       ) ;_ end of vl-remove-if
                               ) ;_ end of mapcar
                  ) ;_ end of setq
                ) ;_ end of length
                1
             ) ;_ end of >
             (> (length
                  (setq _lhrzn (mapcar 'cdr
                                       (vl-remove-if
                                         (function
                                           (lambda (x)
                                             (or (not x)
                                                 (= (car x) 1)
                                             ) ;_ end of or
                                           ) ;_ end of lambda
                                         ) ;_ end of function
                                         _lines
                                       ) ;_ end of vl-remove-if
                               ) ;_ end of mapcar
                  ) ;_ end of setq
                ) ;_ end of length
                1
             ) ;_ end of >
        ) ;_ end of and
         (progn
           (setq _modcol (pl:get-len-perc _lvert 1.0)
                 _modrow (* 0.5
                            (apply 'min
                                   (mapcar 'vla-get-height
                                           (setq _texts (mapcar 'vlax-ename->vla-object
                                                                (pl:entlst-from-ss _texts)
                                                        ) ;_ end of mapcar
                                           ) ;_ end of setq
                                   ) ;_ end of mapcar
                            ) ;_ end of apply
                         ) ;_ end of *
                 _lvert  (pl:clr-near-doub (pl:sort '< _lvert) _modcol)
                 _lhrzn  (pl:sort '> (pl:clr-near-doub (pl:sort '< _lhrzn) _modrow))
                 _texts  (mapcar 'list
                                 (mapcar 'pl:get-cen-pnts (mapcar 'pl:get-bbox _texts))
                                 _texts
                         ) ;_ end of mapcar
                 _mtx    (pl:mk-arr-from-lns _lhrzn _lvert)
                 _mtx    (mapcar (function (lambda (a b) (mapcar 'list a b)))
                                 _mtx
                                 (mapcar 'cdr (cdr _mtx))
                         ) ;_ end of mapcar
                 _mtx    (mapcar (function
                                   (lambda (a)
                                     (mapcar (function
                                               (lambda (b)
                                                 (pl:txts-conc
                                                   (vl-remove-if-not
                                                     (function
                                                       (lambda (c)
                                                         (pl:is-point-in-bbox (car c) b)
                                                       ) ;_ end of lambda
                                                     ) ;_ end of function
                                                     _texts
                                                   ) ;_ end of vl-remove-if-not
                                                 ) ;_ end of cadar
                                               ) ;_ end of lambda
                                             ) ;_ end of function
                                             a
                                     ) ;_ end of mapcar
                                   ) ;_ end of lambda
                                 ) ;_ end of function
                                 _mtx
                         ) ;_ end of mapcar
           ) ;_ end of setq
           (mapcar (function (lambda (b)
                               (mapcar (function (lambda (c)
                                                   (cond (c)
                                                         (t "")
                                                   ) ;_ end of cond
                                                 ) ;_ end of lambda
                                       ) ;_ end of function
                                       b
                               ) ;_ end of mapcar
                             ) ;_ end of lambda
                   ) ;_ end of function
                   (vl-remove-if-not (function (lambda (a) (apply 'or a))) _mtx)
           ) ;_ end of mapcar
         ) ;_ end of progn
      ) ;_ end of if
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun

(defun pl:txts-conc (i-lst)
  (pl:txtsym-chng
    (cond ((not i-lst) nil)
          ((= (length i-lst) 1) (vla-get-textstring (cadar i-lst)))
          (t
           (apply 'strcat
                  (mapcar (function
                            (lambda (c / tmp)
                              (setq tmp (vl-string-trim " " (vla-get-textstring (cadr c))))
                              (if (= (last (vl-string->list tmp)) 45)
                                (vl-string-right-trim "-" tmp)
                                (strcat tmp " ")
                              ) ;_ end of if
                            ) ;_ end of lambda
                          ) ;_ end of function
                          (pl:sort (function
                                     (lambda (a b / tmp)
                                       (setq tmp (angle (car a) (car b)))
                                       (or (< 0 tmp 0.52359878)
                                           (< 4.1887902 tmp 6.2831853)
                                       ) ;_ end of or
                                     ) ;_ end of lambda
                                   ) ;_ end of function
                                   i-lst
                          ) ;_ end of pl:sort
                  ) ;_ end of mapcar
           ) ;_ end of apply
          )
    ) ;_ end of cond
  ) ;_ end of pl:txtsym-chng
) ;_ end of defun

(defun pl:txtsym-chng (str)
  (if str
    (foreach a '(("%%d" "°")
                 ("%%c" "")
                 ("%%p" "±")
                 ("%%%" "%")
                 ("\\U+00B0" "°")
                 ("\\U+2205" "")
                 ("\\U+00B1" "±")
                 ("%%o" "")
                 ("%%u" "")
                )
      (while (vl-string-search (car a) str)
        (setq str (vl-string-subst (cadr a) (car a) str))
      ) ;_ end of while
    ) ;_ end of foreach
  ) ;_ end of if
  str
) ;_ end of defun

(defun pl:mk-arr-from-lns (col row)
  (mapcar (function
            (lambda (a)
              (mapcar (function
                        (lambda (b)
                          (list b a)
                        ) ;_ end of lambda
                      ) ;_ end of function
                      row
              ) ;_ end of mapcar
            ) ;_ end of lambda
          ) ;_ end of function
          col
  ) ;_ end of mapcar
) ;_ end of defun

(defun pl:clr-near-doub (ilst mod / el tmp)
  (if ilst
    (progn
      (setq el  (car ilst)
            tmp (pl:clr-near-doub (cdr ilst) mod)
      ) ;_ end of setq
      (if (and tmp (> el (- (car tmp) mod)))
        tmp
        (cons el tmp)
      ) ;_ end of if
    ) ;_ end of progn
  ) ;_ end of if
) ;_ end of defun

(defun pl:get-len-perc (lst perc)
  (* (abs (- (apply 'max lst) (apply 'min lst))) 0.01 perc)
) ;_ end of defun

(defun pl:extr-pnt-from-line (_line / _p1 _p2)
  (setq _line (entget _line)
        _p1   (cdr (assoc 10 _line))
        _p2   (cdr (assoc 11 _line))
  ) ;_ end of setq
  (list (list (car _p1) (cadr _p1))
        (list (car _p2) (cadr _p2))
  ) ;_ end of list
) ;_ end of defun

(defun pl:extr-pnt-from-lwline (_dxf)
  (mapcar 'cdr
          (vl-remove-if-not
            (function
              (lambda (x)
                (= 10 (car x))
              ) ;_ end of lambda
            ) ;_ end of function
            _dxf
          ) ;_ end of vl-remove-if-not
  ) ;_ end of mapcar
) ;_ end of defun

(defun pl:lwpl-to-segments (_lwline / _vert)
  (setq _lwline (entget _lwline)
        _vert   (pl:extr-pnt-from-lwline _lwline)
  ) ;_ end of setq
  (mapcar 'list
          (if (zerop (logand 1 (cdr (assoc 70 _lwline))))
            (cdr _vert)
            (cons (last _vert) _vert)
          ) ;_ end of if
          _vert
  ) ;_ end of mapcar
) ;_ end of defun

(defun pl:near-orto (_lstpnt _delta / _ang _dir)
  (setq _ang   (rem (apply 'angle _lstpnt) pi)
        _delta (rem (/ (* pi _delta) 180) (* pi 2))
        _dir   (cond ((>= (+ (/ pi 2) _delta) _ang (- (/ pi 2) _delta)) 1)
                     ((or (>= _delta _ang 0) (>= pi _ang (- pi _delta))) 0)
                     (t nil)
               ) ;_ end of cond
  ) ;_ end of setq
  (if _dir
    (cons _dir
          (/ (apply '+
                    (mapcar (if (= _dir 0)
                              'cadr
                              'car
                            ) ;_ end of if
                            _lstpnt
                    ) ;_ end of mapcar
             ) ;_ end of apply
             2
          ) ;_ end of /
    ) ;_ end of cons
  ) ;_ end of if
) ;_ end of defun

(defun pl:sort (func lst)
  (mapcar (function
            (lambda (x)
              (nth x lst)
            ) ;_ end of lambda
          ) ;_ end of function
          (vl-sort-i lst func)
  ) ;_ end of mapcar
) ;_ end of defun

(defun pl:entlst-from-ss (ss)
  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
) ;_ end of defun

(defun pl:get-bbox (obj / minpoint maxpoint)
  (vla-getboundingbox obj 'minpoint 'maxpoint)
  (mapcar 'vlax-safearray->list (list minpoint maxpoint))
) ;_ end of defun

(defun pl:is-point-in-bbox (point bbox)
  (apply 'and
         (mapcar (function
                   (lambda (x y)
                     (<= (apply 'min x) y (apply 'max x))
                   ) ;_ end of lambda
                 ) ;_ end of function
                 (apply 'mapcar (cons 'list bbox))
                 point
         ) ;_ end of mapcar
  ) ;_ end of apply
) ;_ end of defun

(defun pl:get-cen-pnts (pntlst / len)
  (setq len (length pntlst))
  (list (/ (apply '+ (mapcar 'car pntlst)) len)
        (/ (apply '+ (mapcar 'cadr pntlst)) len)
        (/ (apply '+ (mapcar 'caddr pntlst)) len)
  ) ;_ end of list
) ;_ end of defun

(defun pl:get-cen-pnts-2d (pntlst / len)
  (setq len (length pntlst))
  (list (/ (apply '+ (mapcar 'car pntlst)) len)
        (/ (apply '+ (mapcar 'cadr pntlst)) len)
  ) ;_ end of list
) ;_ end of defun

(apply
  (function
    (lambda ()
      (vl-load-com)
      (princ
        (strcat
          "\nУтилита экспорта "рисованных" таблиц из Autocad в Excel - 0.95(бета)"
          "\n©2004 Пётр В. Лоскутов"
          "\n\nТаблицы должны выбираться полностью. В выборку не должны одновременно попадать таблица и штамп!"
          "\nВведите 'tbltoex' в командной строке для начала."
        ) ;_ end of strcat
      ) ;_ end of princ
      (princ)
    ) ;_ end of lambda
  ) ;_ end of function
  nil
) ;_ end of apply