Help!!! помогите по полилинии таблица дирекционных углов, длин линий и номеров точек (Страница 1 из 2)

Программа COOR (режим Sheet)
http://geol-dh.ru/kai_stru.html
Правда точки узлов полилинии нужно указывать вручную.

Попробуйте
CREDO DAT 3.0

2 Провинциал - дирекционный угол - направление с севера по часовой стрелке
Единицы - градусы, минуты, секунды до целых секунд, если возможно с соответствующими символами, длины линий округляются до целых сантиметров. Таблица имеет такой вид:
номер  дирекционный   длина
точки     угол        линии
1
         326 45 12    15,12
2
...
n
         126 45 28    26,56
1

Не помню где скачал, но выслал тебе пакет по земле устройству и геодезии.
Смотри почту.

Спасибо всем, кто откликнулся!
Отдельное спасибо Игорю Богаченко!
Иду проверять почту...
>Ser - я живу в Краснодарском крае

> Solo
Далековато, я - в Средней полосе. Если интерес все-таки остался - см. в электронке.
С уважением

> Игорю
Богаченко
Громаднейшее спасибо за быстрый и эффективный ответ. Правда пока не смотрел (выходной все-таки), но приятно. Успехов во всех начинаниях

поделились програмкой, на аглицком акаде грят, работает, а на русифицированном 2006 не хочет. Может, кто из гуру подскажет, что не так?
(defun c:totbl (/
                *error*                 ; переопределеный обработчик ошибок
                vk_modes
                vk_moder
                vk_tru_text
                my_assoc                ; локализованные функции
                getpolylist
                lstptss
                gr->gms
                mixlists                ; локализованные функции
                mode1
                mode2
                mode3
                modeset
                modezer                 ; списки sysvars
                doc                     ; указатель на активный документ
                th                      ; высота текста
                ff                      ; указатель на выходной файл
                xls                     ; содержимое выходного файла
                txttbl                  ; текст таблицы
                gap                     ; смещение для отрисовки текста от сетки
                tmp                     ; временная переменная
                ptlz                    ; список точек зоны с именами
                pl                      ; полилиния
                ptlpl                   ; список вершин полилинии
                nptlz                   ; список вершин полилинии с именами точек
                flag                    ; флаг замкнутости
                dirangle                ; дирекционный угол
                disdir                  ; список дистанций и дирекционных углов
                ss                      ; набор заготовок таблицы
                tmppt                   ; точка за пределами видимости
                xt
                yt                      ; координаты точки tmppt
                x1
                x23
                x2
                x3
                x4
                x5                      ; X столбцов, полученные при разметке
                yt1
                yt2
                yt3
                yt4                     ; Y линий лаблицы
                yt                      ; текущее значение Y для построения таблицы
                bname                   ; имя блокатаблицы
                bsuff                   ; суффикс имени блока
                str                     ; строковая переменная
                oex                     ; VLA-объект приложение Excel
               )
  ;;--------------------------------------------------------------------------
  ;; обработка ошибок
  (defun *error* (msg /)
    (if (not (member msg '("Function cancelled" "quit / exit abort" "завешить / выйти прервать")))
      (princ (strcat "\nЧто то не так!!! ERRNO = " (rtos (getvar "errno") 2 0) ". " msg))
    ) ;_  if
    (vla-endundomark doc)               ; завершим группу UNDO
    (vl-cmdf "_.u")                     ; отмена сделанных изменений
    (princ)                             ; тихий выход
  ) ;_  defun
;;;-------------- Подпрограммы -----------------
  ;;------------------------------------------------------------------------
  ;; запись в файл Excel
  (defun ac2xl (lst pod / fnt fnd wkbs awb mainsh cnm cell c r)
    (if (setq fnd (getfiled "Путь и имя нового файла" "" "xls" 9))
      (progn
        (if (and (setq fnt (findfile "areatable.xls")) ;_ если найден файл шаблона
                 (findfile fnd) ;_ если есть файл с таким именем
                 (/= fnd fnt) ;_ ну разве кто-то может переписать или удалить шаблон?
                 (null (vl-file-delete fnd)) ;_ удаление существующего файла
            ) ;_  and
          (progn
            (alert (strcat "Файл \""
                           fnd
                           "\" уже существует и имеет признак \"только для чтения\","
                           "\nили не найден файл шаблона \"table.xls\"."
                           "\n\nВыполнение команды отменено."
                   ) ;_  strcat
            ) ;_  alert
            (exit) ;_ аварийный выход при невозможности удаления файла
          ) ;_  progn
        ) ;_  if
        (if (and (null (findfile fnd)) ;_ и нет файла копии
                 (vl-file-copy fnt fnd) ;_ сделать копию файла с новым именем
            ) ;_  and
          (progn
            (setq oex (vlax-get-or-create-object "Excel.Application.10")) ;_ Установить связь с Excel
            (if (null oex) ;_ Если связь не установлена, то аварийно завершить работу
              (progn (alert "Нельзя запустить Microsoft Excel") (exit))
            ) ;_ if
            (vlax-put-property oex "Visible" :vlax-true) ;_ сделать Excel видимым
            (setq wkbs (vlax-get-property oex "Workbooks")) ; Указатель семейства Workbooks
            (setq awb (vlax-invoke-method wkbs "Open" fnd)) ; Открыть книгу и получить указатель книги
            (setq mainsh (vlax-get-property awb "ActiveSheet")) ; Указатель на активный лист
            ;; запись списка в таблицу
            (setq r 4) ;_ строка
            (foreach n lst
              (setq c 1) ;_ колонка
              (foreach m n
                ;; номер ячейкм в формате A1
                (setq cnm (strcat (chr (+ 64 c)) (itoa r)))
                ;; получить указатель на ячейку
                (setq cell (vlax-variant-value (vlax-invoke-method mainsh "Evaluate" cnm)))
                (if (/= m "") ;_при наличии данных
                  ;; установить формат ячейки и записать данные
                  (if (< 1 c 5)
                    (progn
                      (vlax-put-property cell "NumberFormat" (vlax-make-variant "0,00" 8))
                      (vlax-put-property cell "Value2" (vlax-make-variant (atof m) 5))
                    ) ;_  progn
                    (progn
                      (vlax-put-property cell "NumberFormat" (vlax-make-variant "@" 8))
                      (vlax-put-property cell "HorizontalAlignment" (vlax-make-variant -4152 3))
                      (vlax-put-property cell "Value2" (vlax-make-variant (vl-string-subst "°" "%%d" m) 8))
                    ) ;_  progn
                  ) ;_  if
                ) ;_  if
                ;; отобразить границы ячейки
                (vlax-put-property (vlax-get-property cell "Borders") "LineStyle" (vlax-make-variant 1 3))
                (vlax-release-object cell) ;_ освободить ячейку
    (setq cell nil)
                (setq c (1+ c)) ;_ следующая колонка
              ) ;_  foreach
              (setq r (1+ r)) ;_ следующая строка
            ) ;_  foreach
            ;; подвальчик
            (setq cell (vlax-variant-value (vlax-invoke-method mainsh "Evaluate" (strcat "A" (itoa r)))))
            (vlax-put-property cell "Value2" (vlax-make-variant pod 8))
            (vlax-release-object cell) ;_ освободить ячейку
            (setq cell nil)
            (vlax-release-object mainsh) ;_ освободить лист
            (setq mainsh nil)
            (vlax-invoke-method awb "Close" :vlax-true) ; Закрыть книгу
            (vlax-release-object awb) ;_ освободить книгу
            (setq awb nil)
            (vlax-release-object wkbs) ;_ освободить семейство книг
            (setq wkbs nil)
            (vlax-invoke-method oex "Quit") ; отключиться и закрыть Excel
            (vlax-release-object oex) ;_ освободить Excel
            (setq oex nil)
          ) ;_  progn
          (alert (strcat "Файл шаблона не копируется или уже существует файл с именем \""
                         fnd
                         "\" и признаком \"только для чтения\"!\n\nТаблица Excel не записана!"
                         "\n\nВыполнение команды отменено."
                 ) ;_  strcat
          ) ;_  alert
        ) ;_  if
      ) ;_  progn
    ) ;_  if
  ) ;_  defun
  ;;------------------------------------------------------------------------
  ;; рекурсивная функция создания списка assoc со строками и числами
  ;; (my_assoc "3" '(("3" . "wer") (1 . 2) (3 . 4) (5 . 6) ("3" . 7))) -> ("wer" 7)
  ;; (my_assoc 3 '((3 . "wer") (1 . 2) (3 . 4) (5 . 6) ("3" . 7))) -> ("wer" 4)
  (defun my_assoc (el lst)
    (cond
      ((null lst) nil)                  ; список пуст - возврат nil
      ((equal (caar lst) el)            ; подходящее значение -
       (cons (cdar lst) (my_assoc el (cdr lst))) ; - тогда присоединим значение хвоста
      )
      (t (my_assoc el (cdr lst)))       ; не подходит - тогда вызов без присоединения значения хвоста
    ) ;_  cond
  ) ;_  defun
  ;;------------------------------------------------------------------------
  ;;------------------------------------------------------------------------
  ;; Функция создает список вершин полилинии
  ;; (GetPolyList имя_примитива) - возвращает список:
  ;;  ((список_вершин: (100 100 0) (200 100 0) ...)
  ;;            флаг_замкнутости: T или NIL)
  (defun getpolylist (ent / lst c)
    (setq ent (entget ent))
    (cond
      ((= "LWPOLYLINE" (cdr (assoc 0 ent)))
       (list (mapcar '(lambda (x) (append x (list (cdr (assoc 38 ent))))) (my_assoc 10 ent))
             (= 1 (logand 1 (cdr (assoc 70 ent))))
       ) ;_  list
      )
      ((= "POLYLINE" (cdr (assoc 0 ent)))
       (setq c   (= 1 (logand 1 (cdr (assoc 70 ent))))
             ent (entnext (cdr (assoc -1 ent)))
       ) ;_  setq
       (while (progn (setq ent (entget ent)) (/= "SEQEND" (cdr (assoc 0 ent))))
         (if (= "VERTEX" (cdr (assoc 0 ent)))
           (setq lst (cons (cdr (assoc 10 ent)) lst))
         ) ;_  if
         (setq ent (entnext (cdr (assoc -1 ent))))
       ) ;_  while
       (list (reverse lst) c)
      )
    ) ;_  cond
  ) ;_  defun
  ;; конец функции создания списка вершин полилинии
  ;;--------------------------------------------------------------------------
  ;;--------------------------------------------------------------------------
  ;; рекурсивная функция возвращает список вида
  ;;  (("значение_первого_аттрибута_блока" (3d координаты точки вставки блока))
  ;;   ("значение_первого_аттрибута_следующего_блока" (3d координаты точки вставки блока))
  ;;   ......
  ;;  )
  ;; пример вызова (lstptss ss), где ss - selection set
  (defun lstptss (ss / el)
    (ssdel (setq el (ssname ss 0)) ss)  ; удалим el - первый объект из ss
    (cons (list (cdr (assoc 1 (entget (entnext el)))) ; значение аттрибута
                (cdr (assoc 10 (entget el))) ; координаты точки
          ) ;_  list
          (if (> (sslength ss) 0)       ; если есть еще объекты
            (lstptss ss)                ; то рекурсивный вызов
          ) ;_  if
    ) ;_  cons
  ) ;_  defun
  ;; -------------
  ;;--------------------------------------------------------------------------
  ;; сохранение системных переменных
  ;; возвращает список, состоящий из пар (имя_1 значение_1 имя_2 значение_2 ....)
  (defun vk_modes (listvar / ms) ;_ listvar - список системных переменных
    (foreach n listvar (setq ms (cons (getvar n) (cons n ms))))
    (reverse ms)
  ) ;_  defun
  ;;--------------------------------------------------------------------------
  ;; восстановление системных переменных
  (defun vk_moder (ms) ;_ ms - список, состоящий из пар (имя_1 значение_1 имя_2 значение_2 ....)
    (while ms (setvar (car ms) (cadr ms)) (setq ms (cddr ms))) ;_  while
  ) ;_  defun
  ;;------------------------------------------------------------------------------------------
  ;;        *** Отрисовка строки текста ***
  ;; синтаксис (vk_tru_text текст точка_начала высота_текста угол_поворота опция_выравнивания)
  ;; при успешном выполнении возвращает новый примитив TEXT, при ошибке nil
  (defun vk_tru_text (txt t0 h ug just / elast)
    (setq elast (entlast))              ; последний созданный примитив
    (if (= (cdr (assoc 40 (tblsearch "STYLE" (getvar "TEXTSTYLE")))) 0.0)
      (if (/= (strcase just) "L")       ; при нулевой высота текста
        (vl-cmdf "_.TEXT" "_J" just t0 h ug txt)
        (vl-cmdf "_.TEXT" t0 h ug txt)
      ) ;_  if
      (if (/= (strcase just) "L")       ; при фиксированнной высоте текста
        (vl-cmdf "_.TEXT" "_J" just t0 ug txt)
        (vl-cmdf "_.TEXT" t0 ug txt)
      ) ;_  if
    ) ;_  if
    (if (/= elast (entlast))
      (entlast)
      nil
    ) ;_  if
  ) ;_  defun vk_tru_text
  ;;        *** конец отрисовки строки текста ***
  ;;------------------------------------------------------------------------------------------
  ;;------------------------------------------------------------------------------------------
  ;; функция преобразования дес.градусы->строка вида "ггг%%d мм' сс\""
  ;; аргумент - положительное число
  (defun gr->gms (a / g m s)
    (setq g (rtos (fix a) 2 0))
    (setq m (rtos (fix (* (setq a (- a (fix a))) 60)) 2 0))
    (setq s (rtos (fix (* (- (* a 60) (fix (* 60 a))) 60)) 2 0))
    (strcat g
            "%%d "
            (if (= (strlen m) 2)
              m
              (strcat "0" m)
            ) ;_  if
            "' "
            (if (= (strlen s) 2)
              s
              (strcat "0" s)
            ) ;_  if
            "\""
    ) ;_  strcat
  ) ;_  defun
  ;; конец функции преобразования дес.градусы->строка вида "ггг%%d мм' сс\""
  ;;------------------------------------------------------------------------------------------
  ;;------------------------------------------------------------------------------------------
  ;; рекурсивная функция смешивания двух списков
  ;; (MIXLISTS '(1 2 3) '(4 5 6)) -> (1 4 2 5 3 6)
  ;; (MIXLISTS '(1 2 3 4) '(5 6 7)) -> (1 5 2 6 3 7 4)
  ;; (MIXLISTS '(1 2 3 4 5) '(6 7)) -> (1 6 2 7 3 nil 4 nil 5)
  ;; (MIXLISTS '(1 2 3) '(4 5 6 7)) -> (1 4 2 5 3 6 nil 7)
  (defun mixlists (lst1 lst2 /)
    (if (or lst1 lst2)
      (cons (car lst1) (mixlists lst2 (cdr lst1)))
      nil
    ) ;_  if
  ) ;_  defun
  ;;------------------------------------------------------------------------------------------
  ;;==========================================================================================
  ;;        *** непосредственно программа ***
  (gc)
  (setq doc     (vla-get-activedocument (vlax-get-acad-object))
        ;; сохранение и установка переменных и высоты текста и т.д и т.п.
        mode1   (vk_modes '("CMDECHO"
                            "BLIPMODE"
                            "LIMCHECK"
                            "UCSFOLLOW"
                            "CELTYPE"
                            "TEXTSTYLE"
                            "PICKFIRST"
                            "ATTREQ"
                            "ATTDIA"
                            "DIMZIN"
                           )
                ) ;_  vk_modes
        mode2   (vk_modes '("ORTHOMODE" "OSMODE" "SNAPMODE")) ; эти будут меняться часто
        mode3   (vk_modes '("CECOLOR" "CLAYER" "CELWEIGHT")) ; цвет, слой и толщина
        modezer '("ORTHOMODE" 0 "OSMODE" 0 "SNAPMODE" 0)
        modeset (list "BLIPMODE"
                      0
                      "CMDECHO"
                      0
                      "LIMCHECK"
                      0
                      "UCSFOLLOW"
                      0
                      "CELTYPE"         ; тип линий "CONTINUOUS"
                      "CONTINUOUS"
                      "TEXTSTYLE"       ; стиль текста
                      (getvar "DIMTXSTY") ; как в стиле размера
                      "CECOLOR"         ; цвет
                      "BYLAYER"         ; BYLAYER
                      "CLAYER"          ; текущий слой "0"
                      "0"
                      "CELWEIGHT"       ; толщина линии ByLayer
                      -1
                      "PICKFIRST"       ; очистим текущий выбор
                      0
                      "ATTREQ"          ; требование ввода аттрибутов при вставке блока
                      1
                      "ATTDIA"          ; запрет окна диалога для ввода аттрибутов при вставке блока
                      0
                      "DIMZIN"          ; не обрезать хвостовые нули
                      0
                ) ;_  list
  ) ;_  setq
  ;;                     *** НАЧНЕМ ***
  (vla-startundomark doc)               ; начнем группу для отмены командой _.U
  ;; определим параметры
  (vk_moder modeset)                    ; установка переменных
  (vk_moder modezer)                    ; установка режимов отрисовки
  (setvar "tilemode" 0)                 ; переход в PARERSPACE
  (vl-cmdf "_.PSPACE")                  ; переключаемся на PS
  (vl-cmdf "_.zoom" "_e")               ; показать все
  (setvar "cvport" 1)                   ; текущий ВЭ
  (vl-cmdf "_.MSPACE")                  ; переключаемся на MS
  ;; создание списка всех точек зоны
  (if (setq ptlz (ssget "_X" (list '(0 . "INSERT") '(410 . "Model") '(2 . "PZone")))); только нужные блоки
    ;; проверка дубликатов точек зоны
    (progn
      (setq ptlz (lstptss ptlz))
      (setq tmp (mapcar 'cadr ptlz))
      (while tmp
        (if (vl-position (car tmp) (cdr tmp))
          (progn
            (princ "\n")
            (princ (car tmp))
            (alert "Двойные точки в зоне объекта!\nУдалите дубликаты и повторите вызов команды!")
            (exit)
          ) ;_  progn
        ) ;_  if
        (setq tmp (cdr tmp))
      ) ;_  while
    ) ;_  progn
  ) ;_  if
  ;; полилиния и площадь
  (princ "\nУкажите полилинию контура для создания таблицы")
  (setq pl (ssname (ssget "_:E" '((0 . "*POLYLINE"))) 0)) ; выбор полилинии контура
  (vl-cmdf "_.area" "_o" pl)            ; вычислим площадь и периметр полилинии
  (setq pl (getpolylist pl))            ; список вершин и флаг
  (setq flag (cadr pl))                 ; флаг замкнутости
  (setq pl (car pl))                    ; список вершин полилинии
  ;; замкнутый контур надо гарантировать
  (cond
    ((and (not (equal (car pl) (last pl))) flag)
     (setq pl (append pl (list (car pl)))) ; если контур замкнут, добавим в конец первую точку
    )
    ((equal (car pl) (last pl)))        ; первая и последняя точки совпадают
    (t
     (alert "Контур не замкнут!")
     (exit)
    )
  ) ;_  cond
  ;; идентификация номеров точек
  (foreach n pl
    (if (setq tmp (vl-position n (mapcar 'cadr ptlz)))
      (setq nptlz (cons (nth tmp ptlz) nptlz)) ; в список вершину полилинии с именем точки
      (setq nptlz (cons (list "NoName" n) nptlz)) ; в список вершину полилинии без имени точки
    ) ;_  if
  ) ;_  foreach
  (setq tmp nptlz)                      ; вернем порядок следования
  ;; вычисление списка дистанций и дирекционных углов
  ;; с преобразованием в стрОки с начала строкИ таблицы
  (while (cadr tmp)
    (cond
      ((minusp (setq dirangle (- (* pi 1.5) (angle (cadar tmp) (cadadr tmp)))))
       (setq dirangle (+ pi pi dirangle))
      )
      ((>= dirangle (+ pi pi))
       (setq dirangle (- dirangle pi pi))
      )
    ) ;_  cond
    (setq disdir (cons
                   (list ""
                         ""
                         ""
                         (rtos (distance (cadar tmp) (cadadr tmp)) 2 2)
                         (gr->gms (* 180 (/ dirangle pi)))
                   ) ;_  list
                   disdir
                 ) ;_  cons
    ) ;_  setq
    (setq tmp (cdr tmp))
  ) ;_  while
  ;; преобразование номеров точек в стрОки с начала строкИ таблицы
  (setq tmp nil)
  (foreach n nptlz
    (setq tmp (cons                     ; в список вершину полилинии
                (list (car n)
;;;                      ;; полностью
;;;                      (rtos (cadadr n) 2 2)
                      ;; с обрезкой
                      (if (minusp (atof (setq str (rtos (cadadr n) 2 2))))
                        (if (> (strlen str) 7)
                          (strcat "-" (substr str (- (strlen str) 5) 6))
                          str
                        ) ;_  if
                        (if (> (strlen str) 6)
                          (substr str (- (strlen str) 5) 6)
                          str
                        ) ;_  if
                      ) ;_  if
;;;                      ;; полностью
;;;                      (rtos (caadr n) 2 2)
                      ;; с обрезкой
                      (if (minusp (atof (setq str (rtos (caadr n) 2 2))))
                        (if (> (strlen str) 7)
                          (strcat "-" (substr str (- (strlen str) 5) 6))
                          str
                        ) ;_  if
                        (if (> (strlen str) 6)
                          (substr str (- (strlen str) 5) 6)
                          str
                        ) ;_  if
                      ) ;_  if
                      ""
                      ""
                ) ;_  list
                tmp
              ) ;_  cons
    ) ;_  setq
  ) ;_  foreach
  ;; компоновка строк текста таблицы
  (setq txttbl (mixlists tmp disdir))
  (vl-cmdf "_.PSPACE")                  ; переключаемся на PS
  ;; исходные данные для построения
  (setq th 2.5)                         ; высота текста в таблице
  (setq gap 1.8)                        ; отступ текста
  (setq temppt (list (setq xt (* (car (getvar "VSMAX")) 2)) ; временная точка
                     (setq yt (* (cadr (getvar "VSMAX")) 2)) ; за пределами видимости
               ) ;_  list
  ) ;_  setq
  ;; разметка таблицы по горизонтали самыми длинными TEXTами
  (setq x1 0.0)
  (foreach n (append '("Номер" "точки") (mapcar 'car tmp))
    ;; по наиболее длинному элементу первой колонки
    (setq x1 (max (+ xt gap gap (caadr (textbox (entget (vk_tru_text n '(0.0 0.0) th 0 "l"))))) x1))
    (entdel (entlast))
  ) ;_  foreach
  (setq x23 (+ gap
               gap
               (/ (caadr (textbox (entget (vk_tru_text "Координаты точек, м" '(0.0 0.0) th 0 "l")))) 2.0)
            ) ;_  +
  ) ;_  setq
  (setq x2 (+ x1 x23))
  (setq x3 (+ x2 x23))
  (entdel (entlast))
  (setq x4 (+ x3 gap gap (caadr (textbox (entget (vk_tru_text "стороны, м" '(0.0 0.0) th 0 "l"))))))
  (entdel (entlast))
  (setq x5 (+ x4 gap gap (caadr (textbox (entget (vk_tru_text "Дирекционные" '(0.0 0.0) th 0 "l"))))))
  (entdel (entlast))
  ;; отрисовка заготовок таблицы
  ;; шапка таблицы
  (setq ss (ssadd))                     ; набор заготовок
  (setq yt (- yt gap th))               ; строка заголовка
  (vl-cmdf "_attdef"
           ""
           "TBLNAME"
           "Имя таблицы"
           "Ведомость вычисления площади земельного участка"
           (list (+ xt gap) yt)
           th
           0.0
  ) ;_  vl-cmdf
  (ssadd (entlast) ss)
  (vl-cmdf "_attdef" "" "ADD1" "Дополнительные данные 1" "" (list (+ xt gap) (- yt gap th)) th 0.0)
  (ssadd (entlast) ss)
  (vl-cmdf "_attdef"
           ""
           "ADD2"
           "Дополнительные данные 2"
           ""
           (list (+ xt gap) (- yt gap th gap th))
           th
           0.0
  ) ;_  vl-cmdf
  (ssadd (entlast) ss)
  (setq yt1 (- yt gap))                 ; верхняя граница
  (setq yt (- yt1 th gap))              ; первая строка шапки
  (ssadd (vk_tru_text "Номер" (list (/ (+ xt x1) 2.0) yt) th 0 "c") ss)
  (ssadd (vk_tru_text "Координаты точек, м" (list (/ (+ x1 x3) 2.0) yt) th 0 "c") ss)
  (ssadd (vk_tru_text "Длина" (list (/ (+ x3 x4) 2.0) yt) th 0 "c") ss)
  (ssadd (vk_tru_text "Дирекционные" (list (/ (+ x4 x5) 2.0) yt) th 0 "c") ss)
  (setq yt2 (- yt gap))                 ; линия в шапке
  (setq yt (- yt2 th gap))              ; вторая строка шапки
  (ssadd (vk_tru_text "точки" (list (/ (+ xt x1) 2.0) yt) th 0 "c") ss)
  (ssadd (vk_tru_text "X" (list (/ (+ x1 x2) 2.0) yt) th 0 "c") ss)
  (ssadd (vk_tru_text "Y" (list (/ (+ x2 x3) 2.0) yt) th 0 "c") ss)
  (ssadd (vk_tru_text "стороны, м" (list (/ (+ x3 x4) 2.0) yt) th 0 "c") ss)
  (ssadd (vk_tru_text "углы" (list (/ (+ x4 x5) 2.0) yt) th 0 "c") ss)
  (setq yt3 (- yt gap))                 ; линия между шапкой и телом
  (setq yt (- yt3 th gap))              ; первая строка тела таблицы
  ;; тело таблицы
  (foreach n txttbl
    (mapcar '(lambda (txt x) (ssadd (vk_tru_text txt (list (- x gap) yt) th 0 "r") ss))
            n
            (list x1 x2 x3 x4 x5)
    ) ;_  mapcar
    (setq yt (- yt gap th))             ; следующая строка тела таблицы
  ) ;_  foreach
  (setq yt4 (+ yt th))                  ; линия между телом и подвалом
  ;; подвальчик
  (ssadd (vk_tru_text
           (setq str (strcat "Площадь участка "
                             (rtos (getvar "area") 2 0)
                             " кв. м. Периметр "
                             (rtos (getvar "perimeter") 2 0)
                             "м."
                     ) ;_  strcat
           ) ;_  setq
           (list (+ xt gap) (- yt gap))
           th
           0
           "l"
         ) ;_  vk_tru_text
         ss
  ) ;_  ssadd
  ;; сетка
  (mapcar '(lambda (sx sy ex ey)
             (vl-cmdf "_.line" (list sx sy) (list ex ey) "")
             (ssadd (entlast) ss)
           ) ;_  lambda
          (list xt x1 xt xt xt x1 x2 x3 x4 x5)
          (list yt1 yt2 yt3 yt4 yt1 yt1 yt2 yt1 yt1 yt1)
          (list x5 x3 x5 x5 xt x1 x2 x3 x4 x5)
          (list yt1 yt2 yt3 yt4 yt4 yt4 yt4 yt4 yt4 yt4)
  ) ;_  mapcar
  ;; создание и вставка блока таблицы
  (setq bsuff 0)                        ; исходное значение суффикса
  (ssget "_X" '((0 . "INSERT") (2 . "areatable*")))
  (vl-cmdf "_purge" "_b" "areatable*" "_n") ; удаление из БД неиспользуемых блоков таблиц
  (while (tblsearch "BLOCK" (setq bname (strcat "areatable" (rtos bsuff 2 0))))
    (setq bsuff (1+ bsuff))             ; вычисление суффикса для уникального имени блока
  ) ;_  while
  (vl-cmdf "_block" bname temppt ss "") ; создание нового блока таблицы
  (vk_moder mode2)                      ; восстановим привязки
  ;; вставка блока таблицы с значениями атрибутов по умолчанию
  (vl-cmdf "_insert" bname pause 1.0 1.0 0.0 "" "" "")
  ;; запись текста таблицы в файл Excel
  (ac2xl txttbl str)
  (vk_moder mode1)                      ; восстановление переменных
  (vk_moder mode3)                      ; и других переменных
  (redraw)
  (vla-endundomark doc)                 ; завершим группу UNDO
  (gc)
  (princ)
  ;;        ***  конец непосредственно программы ***
  ;;==========================================================================================
) ;_  defun
(vl-load-com)
(princ "\nДля запуска с командной строки: totbl")
(princ)

Немного комментария.
1. (findfile "areatable.xls")
Чего возвращает?
2. В коде идет жесткая привязка к версии Office: если в системе установлен MS Office 2003, строка (vlax-get-or-create-object "Excel.Application.10") возвращает nil, и дальнейшая работа прекращается. Замени на (vlax-get-or-create-object "Excel.Application")
3. В строках

   (setvar "tilemode" 0) ; переход в PARERSPACE
  (vl-cmdf "_.PSPACE") ; переключаемся на PS
  (vl-cmdf "_.zoom" "_e") ; показать все
  (setvar "cvport" 1) ; текущий ВЭ
  (vl-cmdf "_.MSPACE") ; переключаемся на MS

У тебя идет переход в пространство листа, затем в первый попавшийся ВЭ, а затем уже в нем в модель. Соответственно какие координаты в "исходном виде" получатся - не знает никто. Надо выполнять дополнительные преобразования, скорее всего. В ET вроде была функция для подобных задач, но я не помню ее наименования :(
===
ИМХО: не очень ясна роль Excel'a во всем этом софте. Может быть, и без него можно обойтись?

опцию "L" команды "_.TEXT"

Господа Землеустроители поделитесь пожалуста
комплексами "Зем" под А-кад.
В долгу не останусь
Андрей Сергеевич
г.Одесса
ОРФ ДП ЦДЗК