• На форуме с 10 июля 2004г.
  • Сообщений: 8,349
  • Спасибо: 8

Тема: LISP. Определение координат точки, и простановка на плане

;****** KOORD.LSP *******************************************************
;       Определение координат точки и простановка
;       в рисунке  на плане.
;       Разработал  Громов В.В. Декабрь 2000.
;
(defun C:KOORD (/ pt1 pt2 koord)
       (setvar "cmdecho" 0)
       (setq pt1 T)
    (while pt1
       (setq pt1 (getpoint "\n Укажите точку (ENTER - конец): "))
       (if pt1
       (progn
       (setq koord (strcat (rtos (nth 0 pt1) 2 2) " " (rtos (nth 1 pt1) 2 2)))
       (setq pt2 (getpoint "\n Укажите точку вставки текста: "))
       (command "_text" pt2 "" "" koord)
       (princ)
       ))
     )
       (princ)
)

Возможный макрос для кнопки или пункта меню:

^C^C^P(if (not C:KOORD (load "koord")) KOORD

  • SStas
  • Восстановленный участник
  • На форуме с 7 ноября 2005г.
  • Сообщений: 145
  • Спасибо: 0

Re: LISP. Определение координат точки, и простановка на плане

А как эту координату в буфер обмена скопировать?

  • На форуме с 10 июля 2004г.
  • Сообщений: 8,349
  • Спасибо: 8

Re: LISP. Определение координат точки, и простановка на плане

> SStas
Так это же текст. Кликнуть на нем 2 раза и из редактора текста спокойно можно скопировать в буфер обмена.

  • kpblc
  • kpblc
  • Активный участник
  • Откуда: С.-Петербург
  • На форуме с 29 ноября 2004г.
  • Сообщений: 8,348
  • Спасибо: 24

Re: LISP. Определение координат точки, и простановка на плане

> SStas
Сильно подозреваю, что это надо еще для последующей обработки. полностью задачку?

  • На форуме с 10 июля 2004г.
  • Сообщений: 8,349
  • Спасибо: 8

Re: LISP. Определение координат точки, и простановка на плане

> kpblc
Ага, так можно еще параллельно координаты точек и в файл записывать.

  • kpblc
  • kpblc
  • Активный участник
  • Откуда: С.-Петербург
  • На форуме с 29 ноября 2004г.
  • Сообщений: 8,348
  • Спасибо: 24

Re: LISP. Определение координат точки, и простановка на плане

> Владимир Громов
Так я говорю, что полностью задачку надо озвучить, а то окажется, что файл потом открывается в Excele, там присваивается номер точки, еще какие-нить данные, а потом по полученной таблице (сохраненной как csv) строятся точки в каде. Вот это будет весело...

  • SStas
  • Восстановленный участник
  • На форуме с 7 ноября 2005г.
  • Сообщений: 145
  • Спасибо: 0

Re: LISP. Определение координат точки, и простановка на плане

У нас на предприятии есть две системы координат. Одна - основная и в ней всё начерчено, но изредко нужно перевести несколько точек в другую систему координат.
У меня в Экселе формула для этого есть, но туда надо как-то координаты перетаскивать. Хотел чтоб тыкнул на точке (не точке как объекте, а в любой точке экрана) и координаты в буфере обмена оказались. А ещё лучше, чтобы можно было несолько точек тыкать, а потом всё скопом в буфер.

  • kpblc
  • kpblc
  • Активный участник
  • Откуда: С.-Петербург
  • На форуме с 29 ноября 2004г.
  • Сообщений: 8,348
  • Спасибо: 24

Re: LISP. Определение координат точки, и простановка на плане

Ну вот, что я говорил... А потом что с точками вытворяться будет? Обратно в кад? Может, проще в каде сделать конвертацию, задав, например, точки начала координат для основной системы и дополнительной системы? Да и при указании точки запрашивать, конвертировать в дополнительную или нет?

  • SStas
  • Восстановленный участник
  • На форуме с 7 ноября 2005г.
  • Сообщений: 145
  • Спасибо: 0

Re: LISP. Определение координат точки, и простановка на плане

Точки часто нужны просто в виде координат.
А для Када я сам потом сделаю — смещение и угол поворота для другой системы координат известны.

  • На форуме с 10 августа 2004г.
  • Сообщений: 917
  • Спасибо: 5

Re: LISP. Определение координат точки, и простановка на плане

SStas пишет:

>>У меня в Экселе формула для этого есть, но туда надо как-то координаты перетаскивать. Хотел чтоб тыкнул на точке (не точке как объекте, а в любой точке экрана) и координаты в буфере обмена оказались. А ещё лучше, чтобы можно было несолько точек тыкать, а потом всё скопом в буфер.

Тогда подойдет такой вариант
(для А2000 и выше):

(defun defpoints ()
  (setq lst nil)
  (setq loop T)
  (setq    pt  (getpoint "\nПервая точка :")
    lst (cons pt lst)
  )
  (while
    (setq pt (getpoint "\nСледующая точка :" pt))
     (if (null pt)
       (setq loop nil)
     )
     (setq lst (cons pt lst))
  )
  (reverse lst)
)
(defun C:PUN (/              *aplexcel*      *books-colection*
          *excell-cells*  *new-book*      *sheet#1*
          *sheet-collection*          col
          header          iz_listo          punto_datos
          row
         )
;;; Written by  ALEJANDRO LEGUIZAMON -  http://arquingen.tripod.com.co
;;; edited by FATTY T.O.H. - FattyHallex@gmail.com
  (or (vl-load-com))
  (setq punto_datos (defpoints))
  (alert "Просто закрой Эксель")
  (setq    *AplExcel*       (vlax-get-or-create-object "Excel.Application")
    *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
    *New-Book*       (vlax-invoke-method *Books-Colection* "Add")
    *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
    *Sheet#1*       (vlax-get-property *Sheet-Collection* "Item" 1)
    *excell-cells*       (vlax-get-property *Sheet#1* "Cells")
  )
  (vla-put-visible *AplExcel* :vlax-true)
  (setq row 1)
  (setq col 1)
  (setq header '("X" "Y" "Z"))
  (repeat (length header)
    (vlax-put-property
      *excell-cells*
      "Item"
      row
      col
      (vl-princ-to-string (car header))
    )
    (setq header (cdr header))
    (setq col (1+ col))
  )
  (setq    row 2
    col 1
  )
  (repeat (length punto_datos)
    (setq iz_listo (car punto_datos))
    (repeat (length iz_listo)
      (vlax-put-property
    *excell-cells*
    "Item"
    row
    col
    (vl-princ-to-string (car iz_listo))
      )
      (setq iz_listo (cdr iz_listo))
      (setq col (1+ col))
    )
    (setq punto_datos (cdr punto_datos))
    (setq col 1
      row (1+ row)
    )
  )
  (vlax-invoke-method
    *New-Book*
    'SaveAs
    (strcat (getvar "dwgprefix")
        (vl-string-right-trim ".dwg" (getvar "dwgname"))
    )
    -4143
    nil
    nil
    :vlax-false
    :vlax-false
    1
    2
  )
  (vlax-release-object *excell-cells*)
  (vlax-release-object *Sheet#1*)
  (vlax-release-object *Sheet-Collection*)
  (vlax-release-object *New-Book*)
  (vlax-release-object *Books-Colection*)
  (vlax-release-object *AplExcel*)
  (setq *AplExcel* nil)
  (gc)
  (gc)
  (princ)
)
(prompt "\n\t\t***\tНабери в командной строке PUN \t***\n")
(princ)
;|«Visual LISP© Format Options»
(72 2 50 2 nil "end of " 60 9 0 0 0 T T nil T)
;*** DO NOT add text below the comment! ***|;

(Файл Эксель автоматически сохраняется с именем чертежа)
~'J'~

  • SStas
  • Восстановленный участник
  • На форуме с 7 ноября 2005г.
  • Сообщений: 145
  • Спасибо: 0

Re: LISP. Определение координат точки, и простановка на плане

> Олег(jr.)
Спасибо, подошло

  • На форуме с 10 августа 2004г.
  • Сообщений: 917
  • Спасибо: 5

Re: LISP. Определение координат точки, и простановка на плане

> SStas
Удачи :)
~'J'~

  • На форуме с 10 июля 2004г.
  • Сообщений: 8,349
  • Спасибо: 8

Re: LISP. Определение координат точки, и простановка на плане

> Олег(jr.)
Вот интересная программа, а как люди найдут ее? По названию моей темы не догадаешься.

  • На форуме с 10 августа 2004г.
  • Сообщений: 917
  • Спасибо: 5

Re: LISP. Определение координат точки, и простановка на плане

> Владимир Громов
А там где-то ниже есть программа от Random'a
я ее туда перетащу и как раз будет в общей упряжке
Спасибо,
~'J'~

  • Ali
  • Восстановленный участник
  • На форуме с 6 апреля 2006г.
  • Сообщений: 2
  • Спасибо: 0

Re: LISP. Определение координат точки, и простановка на плане

Будте добры, подскажите как определить координаты точек кривой нарисованной в автокаде с интервалом, скажем, в 1 мм. Т.е. я нарисовал кривую, а мне надо выдать таблицу (можно в экселе)координат точек этой кривой (через 1 мм).
С автокадом немного знаком, но программы не писал и не применял, поэтому прошу подсказать что к чему. Плииизззз. очень надо.

  • ABoltrushko
  • Восстановленный участник
  • На форуме с 26 февраля 2003г.
  • Сообщений: 366
  • Спасибо: 1

Re: LISP. Определение координат точки, и простановка на плане

> Ali
Командой Measure разметь свой объект точками через нужный интервал. Точки должны находиться в отдельном слое. Получишь в исходящем файле что-то воде этого:
89.889, 83.035, 0.000
99.643, 100.495, 0.000
109.397, 117.955, 0.000
119.152, 135.416, 0.000
128.906, 152.876, 0.000
Дальше делай что хочешь...
;;; Запись координат точек или блоков в текстовый файл
(DEFUN C:Points2File (/ entity filename fileopen b c d e f g h)
  (SETVAR "CMDECHO" 0)
  (SETQ filename (GETSTRING "\nВведите имя файла: "))
  (SETQ openfile (OPEN filename "w"))
  (SETQ e (ENTGET (CAR (ENTSEL "\nУкажите нужный элемент:"))))
  (SETQ name (CDR (ASSOC 8 e)))  ;; Выбор на слое
  (PRINC "\n")
  (SETQ a (SSGET "X" (LIST (CONS 8 name))))
  (SETQ b (SSLENGTH a))
  (WHILE (> b 0)
    (SETQ b (1- b))
    (SETQ d (SSNAME a b))
    (SETQ entity (ENTGET d))
    (write-line
      (strcat
        (rtos car (cdr (assoc 10 entity))) 2 3)  ", " ; X в Мировой
        (rtos (cadr (cdr (assoc 10 entity))) 2 3) ", "       ; Y в Мировой
        (rtos (caddr (cdr (assoc 10 entity))) 2 3)           ; Z
      )
      openfile
    )
  )
  (close openfile)
  (PRIN1)
)

  • ABoltrushko
  • Восстановленный участник
  • На форуме с 26 февраля 2003г.
  • Сообщений: 366
  • Спасибо: 1

Re: LISP. Определение координат точки, и простановка на плане

> Ali
Командой Measure разметь свой объект точками через нужный интервал. Точки должны находиться в отдельном слое. Получишь в исходящем файле что-то воде этого:
89.889, 83.035, 0.000
99.643, 100.495, 0.000
109.397, 117.955, 0.000
119.152, 135.416, 0.000
128.906, 152.876, 0.000
Дальше делай что хочешь...
;;; Запись координат точек или блоков в текстовый файл
(DEFUN C:Points2File (/ entity filename fileopen b c d e f g h)
  (SETVAR "CMDECHO" 0)
  (SETQ filename (GETSTRING "\nВведите имя файла: "))
  (SETQ openfile (OPEN filename "w"))
  (SETQ e (ENTGET (CAR (ENTSEL "\nУкажите нужный элемент:"))))
  (SETQ name (CDR (ASSOC 8 e)))  ;; Выбор на слое
  (PRINC "\n")
  (SETQ a (SSGET "X" (LIST (CONS 8 name))))
  (SETQ b (SSLENGTH a))
  (WHILE (> b 0)
    (SETQ b (1- b))
    (SETQ d (SSNAME a b))
    (SETQ entity (ENTGET d))
    (write-line
      (strcat
        (rtos car (cdr (assoc 10 entity))) 2 3)  ", " ; X в Мировой
        (rtos (cadr (cdr (assoc 10 entity))) 2 3) ", "       ; Y в Мировой
        (rtos (caddr (cdr (assoc 10 entity))) 2 3)           ; Z
      )
      openfile
    )
  )
  (close openfile)
  (PRIN1)
)

  • kpblc
  • kpblc
  • Активный участник
  • Откуда: С.-Петербург
  • На форуме с 29 ноября 2004г.
  • Сообщений: 8,348
  • Спасибо: 24

Re: LISP. Определение координат точки, и простановка на плане

Код гуляет уже бог знает сколько времени. Как вариант:

;|=============================================================================
*    Функция записи координат точек в указанный файл
=============================================================================|;
(defun c:pt2file (/ *error* file_name file_handle selset item)
  (defun *error* (msg)
    (if    file_handle
      (close file_handle)
      ) ;_ end of if
    (if    (member    message
        '("console break"        "Function cancelled"
          "Функция отменена"        "quit / exit abort"
          "выйти прервать"
          ) ;_list
        ) ;_member
      (princ "\nКоманда прервана пользователем")
      (princ
    (strcat    "\ERRNO # "
        (itoa (getvar "ERRNO"))
        ": "
        message
        "\n"
        ) ;_strcat
    ) ;_princ
      ) ;_if
    (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
    (princ)
    ) ;_ end of defun
  (if
    (and (setq
       file_name (getfiled "Укажите файл"
                   (vla-get-fullname
                 (vla-get-activedocument (vlax-get-acad-object))
                 ) ;_ end of vla-get-fullname
                   ""
                   4
                   ) ;_ end of getfiled
       ) ;_ end of setq
     (setq selset (ssget '((0 . "POINT"))))
     ) ;_ end of and
     (progn
       (setq file_handle (open file_name "w"))
       (while (and selset
           (> (sslength selset) 0)
           ) ;_ end of and
     (setq item (ssname selset 0))
     (ssdel item selset)
     (write-line
       (strcat " X : "
           (car (cdr (assoc 10 (entget item))))
           "\tY : "
           (cadr (cdr (assoc 10 (entget item))))
           "\tZ : "
           (caddr (cdr (assoc 10 (entget item))))
           ) ;_ end of strcat
       file_handle
       ) ;_ end of write-line
     ) ;_ end of while
       (close file_handle)
       ) ;_ end of progn
     ) ;_ end of if
  (princ)
  ) ;_ end of defun

  • wildfire
  • Восстановленный участник
  • На форуме с 8 августа 2006г.
  • Сообщений: 1
  • Спасибо: 0

Re: LISP. Определение координат точки, и простановка на плане

Простите новичка за глупый вопрос. А что с этим кодом делать то? Я в Автокаде далеко не профи, но очень нужна функция экспорта координат точек из автокада в текстовый файл.

  • kpblc
  • kpblc
  • Активный участник
  • Откуда: С.-Петербург
  • На форуме с 29 ноября 2004г.
  • Сообщений: 8,348
  • Спасибо: 24

Re: LISP. Определение координат точки, и простановка на плане

https://www.caduser.ru/oldlink/faq/?part=44

  • VVA
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 29 марта 2006г.
  • Сообщений: 1,859
  • Спасибо: 26

Re: LISP. Определение координат точки, и простановка на плане

Модификация Олег(jr.) (2005-12-27 21:44:49) для экспорта точек в Excel
https://www.caduser.ru/forum/topic26287.html

  • Откуда: Хабаровский / Комсомольск-на-А
  • На форуме с 17 ноября 2006г.
  • Сообщений: 40
  • Спасибо: 0

Re: LISP. Определение координат точки, и простановка на плане

> Олег(jr.)
Прекрасная программка. Но можно до 3-го знака после запятой? Координаты большие (100000.000,500000.000) и приходится переносить начало координат - тогда получается.

  • VVA
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 29 марта 2006г.
  • Сообщений: 1,859
  • Спасибо: 26

Re: LISP. Определение координат точки, и простановка на плане

Собрать все вместе.
Экспорт координат точек, блоков, вершин полилиний и сплайнов, указанных пользователем точек в текстовый файл, Excel или просто вывод на экран.
Команда : COOR
Округление: в соответвие с настройками команды _UNITS (переменная LUPREC)
LUPREC = 3 — 3 знака после запятой
LUPREC = 2 — 2 знака после запятой
и т.д.
Файл сохранить как coor.lsp

;|================== XLS ========================================
*  published https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Purpose: Export of the list of data Data-list in Excell
*             It is exported to a new leaf of the current book.
              If the book is not present, it is created
* Arguments:
              Data-list — The list of lists of data (LIST)
                            ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                            Each list of a kind (Value1 Value2... VlalueN) enters the name in
                            a separate line in corresponding columns (Value1-A Value2-B and .т.д.)
                  header —  The list (LIST) headings or nil a kind (" Signature A " " Signature B "...)
                            If header nil, is accepted ("X" "Y" "Z")
                 Colhide —  The list of alphabetic names of columns to hide or nil — to not hide ("A" "C" "D") — to hide columns A, C, D
                 Name_list — The name of a new leaf of the active book or nil — is not present
* Return: nil
* Usage
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Col1" "Col2" "Col3"  "Col4") '("B") "test")   |;
;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Автор: Владимир Азарко aka VVA
* Назначение: Печать списка данных Data-list в Excell
*             Для вывода создается новая книга
              Вывод осуществляется в первом листе
* Аргументы:
              Data-list — список списков данных (LIST) вида
                            ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                            Каждый список вида (Value1 Value2 ... VlalueN) записывается
                            в отдельную строку в соответствующие столбцы (Value1-A Value2-B и .т.д.)
                  header —  список (LIST) заголовков или nil вида ("Подпись A" "Подпись B" ...)
                            Если header nil, принимается ("X" "Y" "Z")
                 Colhide —  список буквенных названий стоблцов для скрытия или nil — не скрывать
                            ("A" "C" "D") — скрыть столбцы A, C, D
                 Name_list — имя нового листа активной книги или nil — новая книга
* Возврат: nil
* TIPS!!! : При передачи функции xls числовых вещественных данных нет необходимости проверять текущий системный
            разделитель целой и дробной части ("HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
            Функцией на время вывода отключается использование в Excele системного разделителя, разделителем
            целой и дробной части устанавливается точка. После завершения ф-ции все восстанавливается.
Пример вызова
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Столбец1" "Столбец2" "Столбец3" "Столбец4") '("B"))|;
(vl-load-com)
(defun xls ( Data-list header Colhide Name_list / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
  TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
  Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
(if (null Name_list)(setq Name_list ""))
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
  (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
    (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
               *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
              *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
               *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)))
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                  (vl-filename-base(getvar "DWGNAME"))
                  (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
   col 0 cols nil)
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)
(vlax-put-property *Sheet#1* 'Name Name_list)
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_не использовать системные установки
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_разделитель дробной и целой части
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_разделитель тысячей
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (nth (1- col) header)))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length Data-list)(setq iz_listo (car Data-list))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq Data-list (cdr Data-list))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
    (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
    (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
;|=============== Команда COOR ================================================
;https://www.caduser.ru/forum/topic31669.html
EN:
   Export of coordinates of the specified points, the chosen objects: points, blocks, polylines, splines in a text file, Excel.
   Text file — txt, or csv. A rounding off of coordinates according to current adjustments of a command _UNITS (LUPREC !!!)
RUS:
Экспорт координат указанных точек, выбранных объектов: точек, блоков, полилиний, сплайнов в текстовый файл, ексел.
Текстовый файл — либо txt, либо csv. Округление координат в соответствии с текущими настройками команды _UNITS|;
(defun c:COOR(/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
  (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
  (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
  (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
  (setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
  (if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
       ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
         (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
      (t nil))) ret)
  (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)(setq ptcol:mode "Pick"))
  (initget "Указать Точка Блоки Полилиния Pick pOints Blocks poLyline _Pick pOints Blocks poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nВыберите режим [Указать/Точка/Блоки/Полилиния или сплайн] <"
(cadr (assoc ptcol:mode '(("Pick" "Указать")("pOints" "Указать")("Blocks" "Блоки")("poLyline" "Полилиния")))) ">: ")
        (strcat "\nSpecify mode [Pick/pOints/Blocks/poLyline or spline] <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
       (while curPt (setq curPt(getpoint (if IsRus
         "\nУкажите точку или Enter завершения > " "\nPick point or Enter to continue > ")))
  (if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
      ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
         (if IsRus (princ "\nВыберите точки и нажмите Enter ")(princ "\nSelect points and press Enter "))
   (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
      ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
        (if IsRus(princ "\nВыберите блоки и нажмите Enter ")(princ "\nSelect blocks and press Enter "))
     (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
      ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
        (if IsRus(princ "\nВыберите полилинии и нажмите Enter  ")(princ "\nSelect polyline and press Enter "))
     (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst (progn (princ "\n+++++++ Coordinates list +++++++\n")(setq ptLst (mapcar '(lambda(x)(trans x 0 1)) ptLst))
(mapcar '(lambda(x)(princ(strcat "\n"(rtos(car x))","(rtos(cadr x))
(if(= 3(length x))(strcat ","(rtos(nth 2 x))) "")))) ptLst); end mapcar
(princ "\n\n+++++++++ End of list +++++++++")(initget "Файл Excel Не Text Excel Not _Text Excel Not Text Excel Not")
(setq sFlag (getkword (if IsRus "\nСохранить координаты в [Файл/Excel/Не сохранять] <Файл> : "
"\nSave coordinates to [Text file/Excel/Not save] <Text> : ")))
(if(null sFlag)(setq sFlag "Text"))
(cond ((and (= "Text" sFlag)(setq filPath
       (getfiled (if IsRus "Сохранение координат в текстовый файл" "Save Coordinates to Text File") "Coordinates.txt" "txt;csv" 33)))
       (setq cFile(open filPath "w"))(foreach ln ptLst (write-line (strcat (rtos(car ln))","(rtos(cadr ln))
         (if(= 3(length ln))(strcat ","(rtos(nth 2 ln))))) cFile))(close cFile)(initget "Yes No")
       (setq oFlag(getkword (if IsRus "\nОткрыть файл? [Yes/No] <No> : " "\nOpen text file? [Yes/No] <No> : " )))
       (if(= oFlag "Yes")(startapp "notepad.exe" filPath))); end condition #1
     ((= "Excel" sFlag)(xls (mapcar '(lambda(x)(mapcar 'rtos x)) ptLst) nil nil "COOR")); end condition #2
     (t nil)))) (princ)); end of c:COOR

Возможный макрос для кнопки или пункта меню:

^C^C^P(if (null C:COOR)(load "coor"));COOR

Вариант с предустановкой округлкния до 2-х знаков после запятой

^C^C^P(if (null C:COOR)(load "coor"));LUPREC;2;COOR

  • gest
  • Восстановленный участник
  • На форуме с 12 ноября 2006г.
  • Сообщений: 12
  • Спасибо: 0

Re: LISP. Определение координат точки, и простановка на плане

Такая трабла ??

+++++++ Coordinates list +++++++
-1820.27164069,-1819.98454238,0
+++++++++ End of list +++++++++
Сохранить координаты в [Файл/Excel/Не сохранять] <Файл> : E
Ошибка Automation. Во время переименования листа или диаграммы было введено
неправильное имя. Выполните одно из следующих действий:
• убедитесь, что введенное имя не содержит более 31 знака;
• убедитесь, что в имени не содержится ни одного из следующих знаков:  :  \  /
?  *  [  или  ];
• убедитесь, что имя задано.

  • VVA
  • Активный участник
  • Откуда: Беларусь / Минск
  • На форуме с 29 марта 2006г.
  • Сообщений: 1,859
  • Спасибо: 26

Re: LISP. Определение координат точки, и простановка на плане

> gest
При записи в Excel создается новый лист. Имя получаестя так: Имя рисунка + COOR + индекс.
Возможно у тебя длинное название рисунка. И в сумме переваливает за 31 знак.
Добавил проверку на длинну.

;|================== XLS ========================================
*  published https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Purpose: Export of the list of data Data-list in Excell
*             It is exported to a new leaf of the current book.
              If the book is not present, it is created
* Arguments:
              Data-list — The list of lists of data (LIST)
                            ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                            Each list of a kind (Value1 Value2... VlalueN) enters the name in
                            a separate line in corresponding columns (Value1-A Value2-B and .т.д.)
                  header —  The list (LIST) headings or nil a kind (" Signature A " " Signature B "...)
                            If header nil, is accepted ("X" "Y" "Z")
                 Colhide —  The list of alphabetic names of columns to hide or nil — to not hide ("A" "C" "D") — to hide columns A, C, D
                 Name_list — The name of a new leaf of the active book or nil — is not present
* Return: nil
* Usage
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Col1" "Col2" "Col3"  "Col4") '("B") "test")   |;
;|================== XLS ========================================
* Опубликовано https://www.caduser.ru/forum/topic19920.html
               https://www.caduser.ru/forum/topic31444.html
               https://www.caduser.ru/forum/topic31669.html
* Автор: Владимир Азарко aka VVA
* Назначение: Печать списка данных Data-list в Excell
*             Для вывода создается новая книга
              Вывод осуществляется в первом листе
* Аргументы:
              Data-list — список списков данных (LIST) вида
                            ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                            Каждый список вида (Value1 Value2 ... VlalueN) записывается
                            в отдельную строку в соответствующие столбцы (Value1-A Value2-B и .т.д.)
                  header —  список (LIST) заголовков или nil вида ("Подпись A" "Подпись B" ...)
                            Если header nil, принимается ("X" "Y" "Z")
                 Colhide —  список буквенных названий стоблцов для скрытия или nil — не скрывать
                            ("A" "C" "D") — скрыть столбцы A, C, D
                 Name_list — имя нового листа активной книги или nil — новая книга
* Возврат: nil
* TIPS!!! : При передачи функции xls числовых вещественных данных нет необходимости проверять текущий системный
            разделитель целой и дробной части ("HKEY_CURRENT_USER\\Control Panel\\International" "sDecimal")
            Функцией на время вывода отключается использование в Excele системного разделителя, разделителем
            целой и дробной части устанавливается точка. После завершения ф-ции все восстанавливается.
Пример вызова
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Столбец1" "Столбец2" "Столбец3" "Столбец4") '("B"))|;
(vl-load-com)
(defun xls ( Data-list header Colhide Name_list / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26)
  TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
  Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
(if (null Name_list)(setq Name_list ""))
  (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
  (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
    (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
               *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
              *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
          *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
               *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)))
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                  (vl-filename-base(getvar "DWGNAME"))
                  (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
   col 0 cols nil)
(if (> (strlen Name_list) 26)
(setq Name_list (strcat (substr Name_list 1 10) "..." (substr Name_list (- (strlen Name_list) 13) 14))))
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)
(vlax-put-property *Sheet#1* 'Name Name_list)
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_не использовать системные установки
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_разделитель дробной и целой части
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_разделитель тысячей
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (nth (1- col) header)))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length Data-list)(setq iz_listo (car Data-list))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq Data-list (cdr Data-list))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
    (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
    (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))
(vlax-put-property cols 'hidden 1)
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
;|=============== Команда COOR ================================================
;https://www.caduser.ru/forum/topic19920.html
;https://www.caduser.ru/forum/topic31669.html
;
EN:
   Export of coordinates of the specified points, the chosen objects: points, blocks, polylines, splines in a text file, Excel.
   Text file — txt, or csv. A rounding off of coordinates according to current adjustments of a command _UNITS (LUPREC !!!)
RUS:
Экспорт координат указанных точек, выбранных объектов: точек, блоков, полилиний, сплайнов в текстовый файл, ексел.
Текстовый файл — либо txt, либо csv. Округление координат в соответствии с текущими настройками команды _UNITS|;
(defun c:COOR(/ cFile curPt filPath objSet oFlag oldMode ptLst sFlag lw isRus)
(defun group-by-num (lst num / ls ret)(if (= (rem (length lst) num ) 0)(progn (setq ls nil)
  (repeat (/ (length lst) num)(repeat num (setq ls(cons (car lst) ls)lst (cdr lst)))
  (setq ret (append ret (list (reverse ls))) ls nil)))) ret)
(defun PtCollect(SelSet)(mapcar 'cdr (mapcar '(lambda(x)(assoc 10 x))(mapcar 'entget
(vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))))); end of PtCollect
(defun PLCollect(SelSet / ret)
(foreach lw (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp(mapcar 'cadr(ssnamex SelSet))))
  (cond ((wcmatch (vla-get-ObjectName lw) "*Polyline")
  (setq ret (append ret (group-by-num (vlax-get lw 'Coordinates)
  (if (=(vla-get-ObjectName lw) "AcDbPolyline") 2 3)))))
       ((=(vla-get-ObjectName lw) "AcDbSpline")(setq ret (append ret (group-by-num
         (vlax-safearray->list(vlax-variant-value (vla-get-controlpoints lw)))  3))))
      (t nil))) ret)
  (vl-load-com)(setq isRus(= (getvar "SysCodePage") "ANSI_1251"))(if(not ptcol:mode)(setq ptcol:mode "Pick"))
  (initget "Указать Точка Блоки Полилиния Pick pOints Blocks poLyline _Pick pOints Blocks poLyline Pick pOints Blocks poLyline")
(setq oldMode ptcol:mode ptcol:mode
(getkword (if IsRus (strcat "\nВыберите режим [Указать/Точка/Блоки/Полилиния или сплайн] <"
(cadr (assoc ptcol:mode '(("Pick" "Указать")("pOints" "Указать")("Blocks" "Блоки")("poLyline" "Полилиния")))) ">: ")
        (strcat "\nSpecify mode [Pick/pOints/Blocks/poLyline or spline] <"ptcol:mode">: "))) ptLst nil)
(if(null ptcol:mode)(setq ptcol:mode oldMode))
(cond ((= "Pick" ptcol:mode)(setq curPt T)
       (while curPt (setq curPt(getpoint (if IsRus
         "\nУкажите точку или Enter завершения > " "\nPick point or Enter to continue > ")))
  (if curPt (setq ptLst(append ptLst(list (trans curPt 1 0))))))); end condition #1
      ((= "pOints" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "POINT")))))(progn
         (if IsRus (princ "\nВыберите точки и нажмите Enter ")(princ "\nSelect points and press Enter "))
   (setq objSet(ssget '((0 . "POINT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #2
      ((= "Blocks" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "INSERT")))))(progn
        (if IsRus(princ "\nВыберите блоки и нажмите Enter ")(princ "\nSelect blocks and press Enter "))
     (setq objSet(ssget '((0 . "INSERT"))))))(if objSet (setq ptLst(PtCollect objSet)))); end condition #3
      ((= "poLyline" ptcol:mode)(if (not(setq objSet(ssget "_I" '((0 . "*POLYLINE,SPLINE")))))(progn
        (if IsRus(princ "\nВыберите полилинии и нажмите Enter  ")(princ "\nSelect polyline and press Enter "))
     (setq objSet(ssget '((0 . "*POLYLINE,SPLINE"))))))(if objSet (setq ptLst(PLCollect objSet)))); end condition #4
); end cond
(if ptLst (progn (princ "\n+++++++ Coordinates list +++++++\n")(setq ptLst (mapcar '(lambda(x)(trans x 0 1)) ptLst))
(mapcar '(lambda(x)(princ(strcat "\n"(rtos(car x))","(rtos(cadr x))
(if(= 3(length x))(strcat ","(rtos(nth 2 x))) "")))) ptLst); end mapcar
(princ "\n\n+++++++++ End of list +++++++++")(initget "Файл Excel Не Text Excel Not _Text Excel Not Text Excel Not")
(setq sFlag (getkword (if IsRus "\nСохранить координаты в [Файл/Excel/Не сохранять] <Файл> : "
"\nSave coordinates to [Text file/Excel/Not save] <Text> : ")))
(if(null sFlag)(setq sFlag "Text"))
(cond ((and (= "Text" sFlag)(setq filPath
       (getfiled (if IsRus "Сохранение координат в текстовый файл" "Save Coordinates to Text File") "Coordinates.txt" "txt;csv" 33)))
       (setq cFile(open filPath "w"))(foreach ln ptLst (write-line (strcat (rtos(car ln))","(rtos(cadr ln))
         (if(= 3(length ln))(strcat ","(rtos(nth 2 ln))))) cFile))(close cFile)(initget "Yes No")
       (setq oFlag(getkword (if IsRus "\nОткрыть файл? [Yes/No] <No> : " "\nOpen text file? [Yes/No] <No> : " )))
       (if(= oFlag "Yes")(startapp "notepad.exe" filPath))); end condition #1
     ((= "Excel" sFlag)(xls (mapcar '(lambda(x)(mapcar 'rtos x)) ptLst) nil nil "COOR")); end condition #2
     (t nil)))) (princ)); end of c:COOR