Помогите с экспортом координат полилинии в txt

alost · 04.05.2008, 18:34

Здравствуйте!
Возникла проблема есть несколько тысяч объектов из замкнутых полилиний нужно выгрузить координаты всех вершин полилиний в TXT но либо каждый полигон в отдельный файл (методом группового выделения) или все в один но чтобы было разделение между объектами!

Makswell · 05.05.2008, 08:49

Вот, попробуй. Код практически не тестировал.

Код:

[Выделить все]

(defun test (/ ent _file file_desc point_list item1 w-line item2)
  (setq ent (entget (car (entsel "\nВыбери полилинию"))))
  (if (or (= (cdr (assoc 0 ent)) "LWPOLYLINE")
      (= (cdr (assoc 0 ent)) "POLYLINE"))
    (progn
      (while (assoc 10 ent)
	(setq point_list (append point_list (list (cdr (assoc 10 ent)))))
	(setq ent (cdr (member (assoc 10 ent) ent)))
      )
      (setq _file (getvar "dwgname"))
      (if (= (strcase (substr _file (- (strlen _file) 3) 4))
	     (strcase ".dwg")
	  )
	(setq
	  _file	(strcat (substr _file 1 (- (strlen _file) 4)) ".txt")
	)
	(setq _file (strcat _file ".txt"))
      )
      (setq _file (getfiled "сохранить координаты в файл" _file "txt" 9))
      (if _file
	(progn
	  (setq file_desc (open _file "w"))
	  (foreach item1 point_list
	    (setq w-line "")
	    (foreach item2 item1
	      (setq w-line (strcat w-line " " (rtos item2 2 2)))
	    )
	    (write-line w-line file_desc)
	  )
	  (close file_desc)
	)
      )
    )
  )
  (princ)
)

KSI · 05.05.2008, 11:11

В текстовый файл координаты X,Y,Z

Код:

[Выделить все]

;; For AutoCAD R13, R14, R15
;; Координаты вершин 3DPolyline, LwPolyline и Point в текстовый файл.
;; 

(defun C:FCOORD ()

  (defun point_coord ()
    (setq name_point (getstring T "Name point: "))
    (setq coord_x (nth 1 (assoc 10 (entget id_prim))))
    (setq coord_y (nth 2 (assoc 10 (entget id_prim))))
    (setq coord_z (nth 3 (assoc 10 (entget id_prim))))
    (setq coord_xyz (strcat name_point " x=" (rtos coord_x) " y=" (rtos coord_y) " z=" (rtos coord_z)))
    (print coord_xyz id_file)
  ) ; end defun point_coord

  (defun polyline_coord ()
    (setq name_pline (getstring T "Name polyline: "))
    (print name_pline id_file)
    (while (/= "SEQEND" (cdr (assoc 0 (entget (entnext id_prim)))))
      (setq id_prim (entnext id_prim))
      (setq coord_x (nth 1 (assoc 10 (entget id_prim))))
      (setq coord_y (nth 2 (assoc 10 (entget id_prim))))
      (setq coord_z (nth 3 (assoc 10 (entget id_prim))))
      (setq coord_xyz (strcat "x=" (rtos coord_x) " y=" (rtos coord_y) " z=" (rtos coord_z)))
      (print coord_xyz id_file)
    )
    (print " " id_file)
  ) ; end defun polyline_coord

  (defun lwpolyline_coord ()
    (setq name_pline (getstring T "Name polyline: "))
    (print name_pline id_file)
    (setq vert_kol (cdr (assoc 90 (entget id_prim))))
    (setq coord_z (cdr (assoc 38 (entget id_prim))))
    (setq f_vert (assoc 10 (entget id_prim)))
    (setq sp_vert (member f_vert (entget id_prim)))
    (setq i 1)
    (while (<= i vert_kol)
      (setq coord_x (nth 1 (assoc 10 sp_vert)))
      (setq coord_y (nth 2 (assoc 10 sp_vert)))
      (setq coord_xyz (strcat "x=" (rtos coord_x) " y=" (rtos coord_y) " z=" (rtos coord_z)))
      (print coord_xyz id_file)
      (setq sp_vert (cddr (cddr sp_vert)))
      (setq i (+ i 1))
    )
    (print " " id_file)
  ) ; end defun lwpolyline_coord

  (setq id_prim (car (entsel)))
  (while (= id_prim nil)
    (setq id_prim (car (entsel)))
  )
  (setq id_file (open (getfiled "Select Text File" "C:/" "txt" 1) "a"))
  (while (/= id_prim nil)
    (if (= "POINT" (cdr (assoc 0 (entget id_prim)))) (point_coord))
    (if (= "POLYLINE" (cdr (assoc 0 (entget id_prim)))) (polyline_coord))
    (if (= "LWPOLYLINE" (cdr (assoc 0 (entget id_prim)))) (lwpolyline_coord))
    (setq id_prim (car (entsel)))
  )
  (close id_file)
)

KSI · 05.05.2008, 11:17

В текстовый файл координаты X,Y полилиний с выбором объектов. Каждой полилинии дается свое наименование.

Код:

[Выделить все]

(defun C:PLCOOR ()
  (setq id_file (open (getfiled "Select Text File" "C:/" "txt" 1) "a"))
  (setq id_prim (car (entsel)))
  (while (/= id_prim nil)
    (setq n_pline (getstring T "Name polyline: "))
    (print n_pline id_file)
    (while (/= "SEQEND" (cdr (assoc 0 (entget (entnext id_prim)))))
      (setq id_prim (entnext id_prim))
      (setq coor_x (/ (nth 1 (assoc 10 (entget id_prim))) 12960))
      (setq coor_y (/ (nth 2 (assoc 10 (entget id_prim))) 22320))
      (print coor_x id_file)
      (prin1 coor_y id_file)
    )
    (print " " id_file)
    (setq id_prim (car (entsel)))
  )
  (close id_file)
)

alost · 05.05.2008, 12:06

Спасибо большое я теперь с ума не сойду!

Red Nova · 05.05.2008, 14:54

Makswell,
Не пойму как запустить
KSI, У меня #3 не работает.

Цитата:

без выбора объектов. Пробегается по всему файлу

Как раз выбор запрашивает, и надо поочереди давать имена точкам.

Цитата:

Command:
FCOORD
Select object: Name point: a

Select object: Name point: b

Select object: Name point: c

Select object: Name point:

Select object:
nil

Command:

Результат в txt

Код:

[Выделить все]

"a x=1 y=0 z=1" 
"b x=1 y=1 z=0" 
"c x=0 y=1 z=0" 
" x=1 y=1 z=1"

Мне надо координаты всех точек (point) в txt экспоритровать.

Makswell · 05.05.2008, 15:18

Red Nova, запускать надо так: (test)

Кулик Алексей aka kpblc · 05.05.2008, 15:20

Если только для точек, то можно и так:

Код:

[Выделить все]

(defun point2txt
       (/ _dwgru-conv-pickset-to-list file handle res coord *error* selset)
  (defun *error* (msg)
    (vl-catch-all-apply '(lambda () (close handle)))
    (princ msg)
    (princ)
    ) ;_ end of defun

;;; ************************************************************************
;;; * Библиотека DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * _dwgru-conv-pickset-to-list
;;; *
;;; * 03/12/2007 Версия 0001. 
;;; ************************************************************************

  (defun _dwgru-conv-pickset-to-list (value / lst item)
;;; Назначение:
;;; Преобразовывает набор (pickset) в обычный список имен примитивов (ename)
;;; Низкоуровневая функция. Контроль соответствия типов не производится

;;; Параметры: 
;;; value - набор (pickset) или nil если пустой набор
;;; Возврат:
;;;   - список примитивов (Ename)
;;;; Пример
    ;|
(setq point (vla-addpoint (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3d-point '(0 0 0))))
(_dwgru-conv-pickset-to-list (ssget "_L")) ;_(<Имя объекта: 7ef85e00>)
(_dwgru-conv-pickset-to-list (ssadd)) ;_nil
  |;
    (repeat (setq item (sslength value)) ;_ end setq
      (setq lst (cons (ssname value (setq item (1- item))) lst))
      ) ;_ end repeat
    lst
    ) ;_ end of defun

  (if (and (setq file (getfiled "Result" "" "txt" 1))
           (setq selset (ssget "_X" '((0 . "POINT"))))
           ) ;_ end of and
    (progn
      (foreach ent (_dwgru-conv-pickset-to-list selset)
        (setq coord (cdr (assoc 10 (entget ent)))
              res   (cons (strcat "x : "
                                  (vl-princ-to-string (car coord))
                                  "\ty : "
                                  (vl-princ-to-string (cadr coord))
                                  "\tz : "
                                  (vl-princ-to-string (caddr coord))
                                  "\n"
                                  ) ;_ end of strcat
                          res
                          ) ;_ end of cons
              ) ;_ end of setq
        ) ;_ end of foreach
      (setq handle (open file "w"))
      (write-line (apply 'strcat res) handle)
      (close handle)
      ) ;_ end of progn
    ) ;_ end of if
  (princ)
  ) ;_ end of defun

Если для полилиний, то тогда таким образом:

Код:

[Выделить все]

(defun pline2txt
       (/ _dwgru-conv-pickset-to-list file handle res coord *error* selset)

  (defun *error* (msg)
    (vl-catch-all-apply '(lambda () (close handle)))
    (princ msg)
    (princ)
    ) ;_ end of defun

;;; ************************************************************************
;;; * Библиотека DWGruLispLib Copyright ©2007  DWGru Programmers Group
;;; *
;;; * _dwgru-conv-pickset-to-list
;;; *
;;; * 03/12/2007 Версия 0001. 
;;; ************************************************************************

  (defun _dwgru-conv-pickset-to-list (value / lst item)
;;; Назначение:
;;; Преобразовывает набор (pickset) в обычный список имен примитивов (ename)
;;; Низкоуровневая функция. Контроль соответствия типов не производится

;;; Параметры: 
;;; value - набор (pickset) или nil если пустой набор
;;; Возврат:
;;;   - список примитивов (Ename)
;;;; Пример
    ;|
(setq point (vla-addpoint (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3d-point '(0 0 0))))
(_dwgru-conv-pickset-to-list (ssget "_L")) ;_(<Имя объекта: 7ef85e00>)
(_dwgru-conv-pickset-to-list (ssadd)) ;_nil
  |;
    (repeat (setq item (sslength value)) ;_ end setq
      (setq lst (cons (ssname value (setq item (1- item))) lst))
      ) ;_ end repeat
    lst
    ) ;_ end of defun

  (if (and (setq file (getfiled "Result" "" "txt" 1))
           (setq selset (ssget "_X" '((0 . "LWPOLYLINE"))))
           ) ;_ end of and
    (progn
      (foreach ent (_dwgru-conv-pickset-to-list selset)
        (setq coord (mapcar
                      'cdr
                      (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget ent))
                      ) ;_ end of mapcar
              res   (cons
                      (strcat
                        "***"
                        (apply 'strcat
                               (mapcar '(lambda (x)
                                          (strcat "\nx : "
                                                  (vl-princ-to-string (car x))
                                                  "\ty : "
                                                  (vl-princ-to-string (cadr x))
                                                  ) ;_ end of strcat
                                          ) ;_ end of lambda
                                       coord
                                       ) ;_ end of mapcar
                               ) ;_ end of apply
                        "\n"
                        ) ;_ end of strcat
                      res
                      ) ;_ end of cons
              ) ;_ end of setq
        ) ;_ end of foreach
      (setq handle (open file "w"))
      (write-line (apply 'strcat res) handle)
      (close handle)
      ) ;_ end of progn
    ) ;_ end of if
  (princ)
  ) ;_ end of defun

P.S. Запуск соответственно (point2txt) и (pline2txt).

Red Nova · 05.05.2008, 15:46

Кулик Алексей aka kpblc,
Работает. Спасибо.

KSI · 05.05.2008, 16:45

Red Nova,
Да, прошу прощения, был не прав. Невнимательно посмотрел, но если учесть, что это писалось для Автокада 13 и давно им не пользовался, то можно и не бить ногами.

Red Nova · 05.05.2008, 19:37

Мда. Это с каких же пор работает человек, что для 13-го лисп писал? Я начал на 2004-ом.
Хотя так посчитал, годков то не очень много прошло. Наверное лет 10, со времен 13-го.

Кулик Алексей aka kpblc · 05.05.2008, 23:29

Red Nova, а хоть результат-то моего варианта устраивает или "не човчем"? Спрашиваю, т.к. рисовал "на коленке" между совещаниями.

Red Nova · 05.05.2008, 23:50

Дык я сказал что работает, "човчем" устаревает

, все то, еще бы понять как это дело в лиру впихнуть, воще в точку бы было. А коленки видно очень даже подходящие, может там и "fildes purge" родиться

, тока главное, чтобы ты его писал на коленках, и не переставлял чуть по выше, а-то результат не предсказуем

Кулик Алексей aka kpblc · 06.05.2008, 02:29

С Лирой - тут я пас. Если заранее известно, что там формат текстового файла "такой-то", то можно просто выводной формат поменять. Это в общем-то не сильно сложно.
Насчет чистки полей - я в теме уже отписался. Правда, не все так гладко, как хотелось бы

VVA · 07.05.2008, 10:09

Еще до кучи пару ссылок
COOR - Экспорт координат точек, блоков, вершин полилиний и сплайнов, указанных пользователем точек в текстовый файл, Excel или просто вывод на экран

Команда COORN:
Экспорт координат указанных точек, выбранных объектов: точек, блоков, полилиний, сплайнов в текстовый файл, ексел с простановкой номеров
Текстовый файл — либо txt, либо csv.

Рyslan · 07.05.2008, 16:53

Есть прога для создания таблицы с координатами прямо в чертеже? С txt я посмотрел, все получается. а нужно чтобы таблица была акадовская в чертеже

alost · Регистрация: 04.05.2008

Код:

[Выделить все]

;--------------------------ввод площадей-------------------------------------
(defun vp (/ yr txt txtin lang)
 (setq d_tv2  (+ d_tv2 (* mk 2))
       d_tv1  (+ d_tv1 (* mk 2))
     areanew  (strcat "Общая площадь " (rtos areanew 2 2) " кв.м.")
       perim  (strcat "Периметр " (rtos perim 2 0) " м."))
 (command "_text" (list (- (car tv_tab) d_tv1 (* mk 1)) (+ (cadr tv_tab)(* mk 2))) mk "90" perim)
 (setq uu (ssadd (entlast) uu)  d_tv2 (+ d_tv2 (* mk 4)))
 (command "_text" "j" "r" (list (- (car tv_tab) d_tv1 (* mk 1)) (+ (cadr tv_tab) (* mk 38))) mk "90" areanew)
 (setq uu (ssadd (entlast) uu))
);end vp
;--------------------вырезка под блоком ------------------------------------
(defun vstav(/ k linn spi sname i tv)
 (setq k  0.25
    linn  (entlast)
       i  0
      tv  (list(/(+(car(car sp))(car(caddr sp)))2)(/(+(cadr(caddr sp))(cadr(car sp)))2))
 )
 (command "_zoom" mint maxt)
 (while (< k c)
  (command "_offset" k (list linn (car sp)) tv "")
  (setq gr (entlast))
  (kgran)
  (command "_ERASE" gr "")
  (setq sps  sp
          a  (car sps)
        sps  (cdr sps)
          b  (car sps)
  )
  (command "_trim" linn "" "_F" a b)
  (while (cdr sps)
   (setq sps (cdr sps)  b (car sps))
   (command b)
  );end while
  (command a "" "")
  (setq k (+ 0.25 k))
 );end while
 (command "_offset" 0.25 (list linn maxt) tv "")
 (setq gr (entlast))
 (kgran)
 (command "_erase" "_c" (car sp) (caddr sp) linn ""  "_zoom" "_p")
);end vstav
;-------------------------- перeвод в градусы -------------------------------
(defun radgr (/ ugol udtl )
 (setq ugol  (angtos ug 1 4)    ; °
       udtl  (strlen ugol)      ; находим длину текста для выравнивания по правому краю
         ug  (strcat (substr "          " 1 (- 10 UDtl)) ugol)
       ansi  nil
       ansi  (wcmatch ug "??????'*")
 )
 (if (not ansi) (setq ug (strcat (substr ug 2 7) " " (substr ug 9))))
 (setq ansi (wcmatch ug "???d*"))
 (if (not ansi) (setq ug (strcat (substr ug 2 4) " " (substr ug 6))))
 (setq ug (strcat (substr ug 1 3) "%%d" (substr ug 5)))
);end radgr
; ----------------------------   РУМБ   -------------------------------------
(defun rumb ()
 (setq direkt (car spisok_ug))
 (setq svzn " ")
);end rumb
;-------------- дирекционный угол  между точками ----------------
(defun ug_dir(/ xy)
 (setq xy spisok_koord)
 (while xy
  (if (cdr xy)
   (setq spisok_ug (cons (angle (car xy) (cadr xy)) spisok_ug)  xy (cdr xy))
   (setq spisok_ug (cons (angle (car xy) (car spisok_koord)) spisok_ug) xy (cdr xy))
  );end if
 );end while
);end ug_dir
;-------------- расстояние между точками
(defun rasst (/ xy)
 (setq xy spisok_koord)
 (while xy
  (if (cdr xy)
   (setq spisok_dlin (cons (distance (car xy) (cadr xy)) spisok_dlin)  xy (cdr xy))
   (setq spisok_dlin (cons (distance (car xy) (car spisok_koord)) spisok_dlin) xy (cdr xy))
  );end if
 );end while
);end rasst
;------------- Определение координат участка (выносные линии) ----------------
(defun koord_uch (/ ang xy vangle xyt pbck pbcke deltax deltay pbtx pbty pbt)
  (setq anstchk "Y")
(progn
     (setq mznom nil)
     (setq boolParam 1)
     (while (and (/= mznom "Д")(/= mznom "Y")(/= mznom "Н")(/= mznom "N")(/= mznom ""))
      (setq mznom (strcase (getstring "\n Проставляем номера? <Н>: ")))
     );end while
     (if (or (= mznom "N") (= mznom "Н") (= mznom ""))
      (setq boolParam 0)
     );end if
   );end progn
 (while sp_uch
  (setq xy (car sp_uch)  sp_uch (cdr sp_uch))
  (if xyt
   (if (< (distance xyt xy) 0.05)
    (progn
     (princ "\n ")
     (alert "Расст. между точками < 5см. Редактируйте линию")
     (setvar "cmdecho" 1)
     (command "_undo" "_B")
     (exit)
    );end progn
   );end if
  );end if
  (setq        n  (+ n 1)
   sNum  (strcat "н" (rtos n 2 0))
        spisok_n  (cons sNum spisok_n)
    spisok_koord  (cons xy spisok_koord)
             ang  0)
  ;(setq sNum (strcat "н" (rtos n 2 0)))
  (if (= boolParam 1)
  (command   "_layer" "s" "egrz" "" ""
    "_color" "_byl" ""
     "_zoom" "c" xy (* mk (/ mksh 50))
             "_insert" "mznak1" xy (/ mksh 500) (/ mksh 500) "90"
             "_text" "j" "mc" xy (* mk (/ mksh 1000)) "90" sNum
             "_move"   "l" "" xy pause
             "_layer" "s" "document" "" ""
  )
 );end while
)
 (command "zoom" "e")
);end koord_uch

;----------------------------- Определение параметров участка----------------
(defun param_uch (/ tv_tab spisok_koord spisok_dlin spisok_rumb spisok_ug spisok_n d_tv1
                    d_tv2 lang koordx koordy dlina ug nt direkt svzn areanew mint maxt c uu
                    spr i ugo sim perim
                 )
 (koord_uch)
 (setq spisok_koord (reverse spisok_koord))
 (rasst)
 (setq spisok_dlin (reverse spisok_dlin))
 (ug_dir)
 (setq spisok_ug (reverse spisok_ug))
 (command "_area" "_e" gr)       ;ищем площадь
 (setq areanew (getvar "area")  perim (getvar "perimeter"))
;-------------------округление---------------------------------------
;       (if (< (-  areanew (/ (float (fix (* 1 areanew))) 1)) 0.5)
;           (setq areanew (/ (float (fix (* 1 areanew))) 1))
;           (setq areanew (+ 1 (/ (float (fix (* 1 areanew))) 1)))
;       );end if
;---------------------------------------------------------------------
 (setq spisok_area  (cons areanew spisok_area)
             d_tv1  (* mk -1)
             d_tv2  0
          spisok_n  (reverse spisok_n)
 )
 (setq tv_tab (list (car xymax) (- (cadr xymin) (* mk 70))))
 (command "_line" tv_tab (list (+ (car tv_tab) (* mk 5.5)) (cadr tv_tab)) "")
 (setq uu (ssadd (entlast)))
 (command "_line" (list (+ (car tv_tab) (* mk 5.5)) (cadr tv_tab))
                  (list (+ (car tv_tab) (* mk 5.5)) (+ (cadr tv_tab) (* mk 39))) ""
 )
 (setq uu (ssadd (entlast) uu))
 (command "_line" (list (+ (car tv_tab) (* mk 5.5)) (+ (cadr tv_tab) (* mk 39)))
                  (list (car tv_tab)(+ (cadr tv_tab) (* mk 39))) ""
 )
 (setq uu (ssadd (entlast) uu))
 (command "_line" (list (+ (car tv_tab) (* mk 0.5)) (+ (cadr tv_tab) (* mk 39)))
                  (list (+ (car tv_tab) (* mk 0.5)) (cadr tv_tab)) "")
 (setq uu (ssadd (entlast) uu))
 (command "_line" (list (+ (car tv_tab) (* mk 3)) (cadr tv_tab))
                  (list (+ (car tv_tab) (* mk 3)) (+ (cadr tv_tab) (* mk 39))) ""
 )
 (setq uu (ssadd (entlast) uu))
 (command "_line" (list (+ (car tv_tab) (* mk 3)) (+ (cadr tv_tab) (* mk 4)))
                  (list (car tv_tab) (+ (cadr tv_tab) (* mk 4))) ""
 )
 (setq uu (ssadd (entlast) uu))
 (command "_line" (list (+ (car tv_tab) (* mk 3)) (+ (cadr tv_tab) (* mk 12)))
                  (list (car tv_tab) (+ (cadr tv_tab) (* mk 12))) ""
 )
 (setq uu (ssadd (entlast) uu))
 (command "_line" (list (+ (car tv_tab) (* mk 3)) (+ (cadr tv_tab) (* mk 21)))
                  (list (car tv_tab) (+ (cadr tv_tab) (* mk 21))) ""
 )
 (setq uu (ssadd (entlast) uu))
 (command "_line" (list (+ (car tv_tab) (* mk 3)) (+ (cadr tv_tab) (* mk 28)))
                  (list (car tv_tab) (+ (cadr tv_tab) (* mk 28))) ""
 )
 (setq uu (ssadd (entlast) uu))
 (command "_text" "j" "c" (list (+ (car tv_tab) (* mk 3.5)) (+ (cadr tv_tab) (* mk 19)))
                  (* mk 1.5) "90" "Геоданные"
 )
 (setq uu (ssadd (entlast) uu))
 (command "_text" "j" "c" 
                  (list(+(car tv_tab)mk)(+(cadr tv_tab)(* mk 2)))(* mk 1.5) "90" "N")
 (setq uu (ssadd (entlast) uu))
 (command "_text" "j" "c" 
                  (list(+(car tv_tab)mk)(+(cadr tv_tab)(* mk 8)))(* mk 1.5) "90" "X")
 (setq uu (ssadd (entlast) uu))
 (command "_text" "j" "c" 
                  (list (+ (car tv_tab) mk) (+ (cadr tv_tab) (* mk 17))) (* mk 1.5) "90" "Y")
 (setq uu (ssadd (entlast) uu))
 (command "_text" "j" "c"
                  (list(+(car tv_tab)mk)(+(cadr tv_tab)(* mk 24.5))) (* mk 1.5) "90" "Длина")
 (setq uu (ssadd (entlast) uu))
 (command "_text" "j" "c" 
                  (list(+(car tv_tab)mk)(+(cadr tv_tab)(* mk 33))) (* mk 1.5) "90" "Дир.углы")
 (setq uu (ssadd (entlast) uu))
 (while spisok_koord
  (setq d_tv1  (+ d_tv1 (* mk 2))
        d_tv2  (+ d_tv2 (* mk 2))
           ;nt  (rtos (car spisok_n) 2 0)
           nt  (car spisok_n)
       koordx  (rtos (car (car spisok_koord)) 2 2)
       koordy  (rtos (cadr (car spisok_koord)) 2 2)
        dlina  (rtos (car spisok_dlin) 2 2)
           ug  (car spisok_ug)
  )
  (radgr)
  (setq lang (* mk (* 0.75 (strlen nt))))
  (command "_text" (list(-(car tv_tab)d_tv1)(-(+(cadr tv_tab)(* mk 3))lang)) mk "90" nt)
  (setq uu (ssadd (entlast) uu))
  (setq lang (* mk 0.75 (strlen koordx)))
  (command "_text" (list(-(car tv_tab)d_tv1)(-(+(cadr tv_tab)(* mk 11))lang))mk "90" koordx)
  (setq uu (ssadd (entlast) uu))
  (setq lang (* mk 0.75 (strlen koordy)))
  (command "_text" (list(-(car tv_tab)d_tv1)(-(+(cadr tv_tab)(* mk 20))lang ))mk "90" koordy)
  (setq uu (ssadd (entlast) uu))
  (setq lang (* mk 0.75 (strlen dlina)))
  (command "_text" (list(-(car tv_tab)d_tv2)(-(+(cadr tv_tab)(* mk 27))lang))mk "90" dlina)
  (setq uu (ssadd (entlast) uu))
  (setq lang (* mk (* 0.75 (strlen ug))))
  (setq uu (ssadd (entlast) uu))
 (setq i 0  ugo "")
 (while (< i (strlen ug))
  (setq i (1+ i) sim (substr ug i 1))
  (if (equal sim "%") (setq i (+ i 2) sim "\370"))
  (setq ugo (strcat ugo sim))
 );end while
  (rumb)
  (setq ug direkt)
  (radgr)
  (setq direkt  (strcat svzn ug)
   spisok_dlin  (cdr spisok_dlin)
  spisok_koord  (cdr spisok_koord)
     spisok_ug  (cdr spisok_ug)
      spisok_n  (cdr spisok_n)
  )
  (setq lang (* mk (* 0.75 (strlen direkt))))
  (command "_text" (list(-(car tv_tab)d_tv2)(-(+(cadr tv_tab)(* mk 40))lang))mk "90" direkt)
  (setq uu (ssadd (entlast) uu)  i 0  ugo "")
  (while (< i (strlen direkt))
   (setq i (1+ i)  sim (substr direkt i 1))
   (if (equal sim "%") (setq i (+ i 2) sim "\370"))
   (setq ugo (strcat ugo sim))
  );end while
 );end while
 (vp)
 (if (< (- (car tv_tab) d_tv2) (car xymin))
  (setq xyzmin (list (- (- (car tv_tab) d_tv2) (* mk 30)) (cadr tv_tab)))
  (setq xyzmin (list (car xymin) (cadr tv_tab)))
 );end if
 (command "_line" (list (+ (- (car tv_tab) d_tv2) (* mk 3.5)) (cadr tv_tab))
                  (list (+ (- (car tv_tab) d_tv2) (* mk 3.5)) (+ (cadr tv_tab) (* mk 39))) ""
 )
 (setq uu (ssadd (entlast) uu))
 (command "zoom" "e")
 (command "_extend"(entlast)"" "_f" (list(+(car tv_tab)(* mk 0.1))(+(cadr tv_tab)(* mk 39)))
                                    (list(+(car tv_tab)mk)(cadr tv_tab)) "" ""
          "_line" (list (+ (- (car tv_tab) d_tv1) (* mk 0.5)) (cadr tv_tab))
                  (list (+ (- (car tv_tab) d_tv1) (* mk 0.5)) (+ (cadr tv_tab) (* mk 39))) ""
 )
 (setq uu (ssadd (entlast) uu))
 (command "_trim" (entlast) "" "_f" (list(-(car tv_tab)d_tv1(* mk 0.5))(+(cadr tv_tab)mk))
                                    (list(-(car tv_tab)d_tv1(* mk 0.5))(+(cadr tv_tab)(* mk 38))) "" ""
 )
 (setq mint (list (- (- (car tv_tab) d_tv2) mk) (- (cadr tv_tab) mk))
       maxt (list (+ (car tv_tab) (* mk 9)) (+ (cadr tv_tab) (* mk 40)))
 )
 (command "_pline" mint (list (car maxt)(cadr mint)) maxt (list (car mint)(cadr maxt)) "_c")
 (setq uu (ssadd (entlast) uu))
 (setq gr (entlast))
 (princ "\n Укажите точку вставки таблицы \n")
 (command "_move" uu "" mint pause)
 (kgran)
 (setq mint (car sp)  maxt (caddr sp)  spr sp)
 (while spr
  (if (< (car (car spr)) (car  mint)) (setq mint (list (car (car spr)) (cadr mint))))
  (if (< (cadr(car spr)) (cadr mint)) (setq mint (list (car mintc) (cadr(car spr)))))
  (if (> (car (car spr)) (car  maxt)) (setq maxt (list (car (car spr)) (cadr maxt))))
  (if (> (cadr(car spr)) (cadr maxt)) (setq maxt (list (car maxt) (cadr (car spr)))))
  (setq spr (cdr spr))
 );end while
 (if (< (- (distance (car sp) (cadr sp)) 2) (* mk 29))
  (setq c (/ (/ (- (distance (car sp) (cadr sp)) 2) mk) 2))
  (setq c 14.5)
 );end if
 (command "_move" uu "" maxt (list (car maxt) (+ (cadr maxt) (* mk 1000)))
          "_erase" gr ""
          "_pline" (car sp) (cadr sp) (cadr (reverse sp)) (car (reverse sp)) "_c"
 )
 (vstav)
 (command "_move" uu "" (list (car maxt) (+ (cadr maxt) (* mk 1000))) maxt)

);end param_uch

; -----------------определение координат вершин мн-ка------------------------
(defun kgran (/ p1 p2)
 (setq sp nil p1 (entget gr))
 (while p1
  (setq p2 (car p1))
  (if (= (car p2) 10)
   (setq sp (append sp (list (list (caddr p2) (- (cadr p2))))))
  );end if
  (setq p1 (cdr p1))
 );end while
);end kgran
 
;-----------------------Автоматический выбор масштаба------------------------
(defun lang (/ versh s_ver tt pt ypt1 xpt1 pt1 st stp  nam ename x y xmin xmax ymin ymax)
 (setq nam name)
 (while nam
  (setq ename  (car nam)
          nam  (cdr esel)
          stp  nil
        s_ver  (entget ename)
           tt  (cdr (assoc 0 s_ver))
           pt  (assoc 10 s_ver)
         ypt1  (- (cadr pt))
         xpt1  (caddr pt)
          pt1  (list xpt1 ypt1)
          stp  (list pt1)
        versh  (entnext (cdr (assoc -1 s_ver)))
            tt  (cdr (assoc 0 s_ver))
  )
  (while (= tt "VERTEX")
   (setq pt  (assoc 10 s_ver)
       ypt1  (- (cadr pt))
       xpt1  (caddr pt)
        pt1  (list xpt1 ypt1)
        stp  (append stp (list pt1))
      versh  (entnext (cdr (assoc -1 s_ver)))
      s_ver  (entget versh)
         tt  (cdr (assoc 0 s_ver))
   )
  );end while
  (setq st (append st stp))
 );end while
;---------------------------------------------------------------------
 (setq stp st  xmin  1000000  ymin  1000000  xmax -1000000  ymax -1000000)
 (while stp
  (setq x (car (car stp))  y (cadr (car stp))  stp (cdr stp))
  (if (< x xmin) (setq xmin x))
  (if (> x xmax) (setq xmax x))
  (if (< y ymin) (setq ymin y))
  (if (> y ymax) (setq ymax y))
 );end while
 (setq xymin (list xmin ymin)  xymax (list xmax ymax))
);end lang
 
;---------------------Выбор
(defun slight (/ esel ename enam)
(setq esel nil ename nil enam nil)
 (while (not esel)
  (while (not esel) (setq esel (entsel "\n Укажите полилинию \n")))
  (setq ename (car esel)  enam (entget ename))
  (if (/= (cdr (assoc 0 enam)) "LWPOLYLINE") (setq esel nil))
 );end while
 (setq name (list ename))
 (setq mksh 500.0)
 (setq ans nil)
    (while (and (/= ans "Н")(/= ans "N")(/= ans "Y")(/= ans "Д")(/= ans ""))
     (princ "\n Масштаб 1:")
     (princ (rtos mksh 5 0))
     (princ "\n")
     (setq ans (strcase (getstring "\n Изменить масштаб? <Н>: ")))
    );end while
    (if (or (= ans "Y") (= ans "Д"))
     (progn
      (setq mksh 0)
      (while (and (/= mksh 500) (/= mksh 1000) (/= mksh 2000) (/= mksh 5000) (/= mksh 7500)
              (/= mksh 10000) (/= mksh 15000) (/= mksh 25000) (/= mksh 50000) (/= mksh 100000))
       (setq mksh (getreal "\n Введите масштаб :  1:"))
      );end while
      ;(command "_erase" ram "")
     );end progn 
    )
 
);end slight 
 
 ;------------------Автоматическое включение слоёв---------------------
(defun asloi ( )
 (setvar "cmdecho" 0)
 (if (tblsearch "layer" "document")
  (command "_LAYer" "_s" "document" "" "_color" 5)
  (command "_LAYER" "_n" "document" "_c" 5 "document" "_s" "document" "")
 );end if
 ;(command "_layer" "_off" "*" "_y" "_on" "GEO,MZ,ZONA,MASSIV,BLOCK,PLOT,BUILDING,REDLINE,OLD_OTVOD,DOCUMENT,ZEM_OTVOD" ""
 ;         "_color" "_byl" )
);end asloi
 
; ========================================
;     Г О Л О В Н А Я    П Р О Г Р А М М А
; ========================================
; *******  написание таблицы координат для любой полилинии *******
(defun c:sk (/ name mk mks xymin xymax txty fname f)
 (command "_undo" "_m")
 (if (not c:reva)(load "revar")) (c:reva)
 (command "snap" "off"
          "osnap" "off")
 (setq mk 1.5)
 (asloi)
 (slight) 
 (lang)
 (setq n 0  lin name)
 (while lin
  (setq gr (car lin)  lin (cdr lin))
  (if (or (= ans "N") (= ans "Н")) (setq n 0))
  (kgran)
  (setq sp_uch sp)
  (param_uch) 
 );end while
 (setvar "cmdecho" 1)
 (command "zoom" "e")
);end c:d_4

alost · 07.05.2008, 19:47

запускается командой sk

VVA · 08.05.2008, 11:11

alost, В локализованном Автокаде работать не будет, т.к. кое-где опции команд заданы без префикса _

Цитата:

(command "_text" "j" "c" ... -> (command "_text" "_j" "_c"
(command "zoom" "e") -> (command "_zoom" "_e")

alost · 08.05.2008, 12:59

Наша компания использует автокад для чертежа земельных участков в двух мерной системе координат XY и у меня все работает!
Работает вместе с этим шаблоном

04.05.2008, 18:34		#1
Помогите с экспортом координат полилинии в txt alost Регистрация: 04.05.2008 Сообщений: 5 Здравствуйте! Возникла проблема есть несколько тысяч объектов из замкнутых полилиний нужно выгрузить координаты всех вершин полилиний в TXT но либо каждый полигон в отдельный файл (методом группового выделения) или все в один но чтобы было разделение между объектами!
Просмотров: 17431

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
LISP. Вставка в таблицу поля, соотвествующего площади примитива	Profan	Готовые программы	272	06.06.2021 23:12
Экспорт координат из dxf в txt	eilukha	Вертикальные решения на базе AutoCAD	14	26.04.2008 21:53
Помощь по Лире	Серега М	Лира / Лира-САПР	52	28.05.2007 02:47
Построение полилинии по таблице координат	Борода	Программирование	11	21.01.2005 18:44
VBA и система координат	Ра	Программирование	3	10.12.2003 17:40

Опции темы	Поиск в этой теме
	Поиск в этой теме: Расширенный поиск

	Реклама i