Информационный портал для профессионалов в области САПР
Вы не вошли. Пожалуйста, войдите или зарегистрируйтесь.
Форумы CADUser → Отрасль → Геодезия и картография → Автоматическая расстановка блоков на точки
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Подскажите пожалуйста, как в AutoCAD 2002-2006 в автоматическом режиме расставить УЗ "отметка" в виде блока на все точки, полученные из съемки? Может у кого-нибудь есть специальная программулина для этого? Заранее спасибо!
В ToolPack есть функция вставки блоков по характерным точкам выделенных объектов.
(defun ktif-kadastr::insert-points ( / ENAME NUMBER PREFIX
A B NBL PL PLO PLO1 N TORMOZ, NUMERAZ
ss pnumer c d mimo ind1)
; A B NBL PL PLO N TORMOZ C D MIMO IND1 - ввел КСП
; (initget 1)
; (setq number (getint "\nНачальный номер:"))
; (setq prefix (vl-string-right-trim
; " "
; (vl-string-left-trim " " (getstring t "\nПрефикс:"))
; )
; )
;; Выбор блока для вставки
;; Отмена выравнивания
(COMMAND "OSNAP" "OFF")
(setq a (ktif-entsel
"\nВыберите блок для вставки:"
'("INSERT")
""
nil
) ;_ end ktif-entsel
) ;_ end setq
(setq a (car a))
;; (setq a (car (entsel))) ;; Имя выбранного объекта (блока)
(setq b (entget a)) ;; Определение блока - символа
(setq nbl (cdr (assoc 2 b))) ;; Наименование выбранного блока (BL_975 или BL_976)
;; Конец выбора блока для вставки
;; Выбор полилинии
(initget 1 "Y N")
(setq pnumer (getkword "\nПроставлять точки по всем участкам или по одному ? [Y/N]:"))
(if (= pnumer "Y") ;; Сквозная нумерация всех участков
(progn
(prompt "\nВыберите полигоны...")
(setq ss (ssget '((0 . "LWPOLYLINE,POLYLINE"))))
(if ss
(progn
(initget 1 "Y N")
(setq numeraz (getkword "\nБудем нумеровать точки ? [Y/N]:"))
(if (= numeraz "Y")
(progn
(initget 1)
(setq number (getint "\nНачальный номер:"))
(setq prefix (vl-string-right-trim
" "
(vl-string-left-trim " " (getstring t "\nПрефикс:"))
)
)
); End Progn
) ; End if
(if (= numeraz "N")
(setq number 0)
)
(setq ind 0)
(while (setq ename (ssname ss ind))
(setq plo (entget ename))
(setq n 0) ;; Установка счетчика на 0
(setq tormoz nil)
(while (< n (length plo)) ;; Цикл по полилинии
(setq mimo "N") ; переменная, отвечающая за пропуск уже облоченного узла
(setq plo1 (nth n plo))
(if (= 10 (car plo1)) ;; Если запись координат
(progn
(setq t1 (cdr plo1)) ;; t1 - координаты вставки
(setq t1 (list (abs (car t1)) (abs (cadr t1)))) ;; положительные координаты вставки
;; (setq t1 (list (car t1) (cadr t1))) ;; координаты вставки Если использовать это - то расставятся блокив узлах с отрицательными коорд.
;; при вставке координат без abs не всегда проставляются точки в объектах ВИНГЕО (считается, что там X - минусовой)
(if (or (/= (car t1) (car tormoz)) (/= (cadr t1) (cadr tormoz)))
;; (if (/= t1 tormoz)
(progn
; проверка наличия блока с номером в узле полилинии
(setq c (ssget "C" (list (- (car t1) 0.01) (+ (cadr t1) 0.01)) (list (+ (car t1) 0.01) (- (cadr t1) 0.01))))
(if c
(progn
; (setq d (sslength c))
(setq ind1 0)
(while (< ind1 (sslength c))
(setq d (entget (ssname c ind1)))
(if (= "INSERT" (cdr (assoc 0 d)))
(setq mimo "Y")
);end if
(setq ind1 (+ 1 ind1))
); end while
);end progn
); end if
; конец проверки наличия блока с номером в узле полилинии
; вставка блока производится только если в узле уже нет блока
(if (= "N" mimo)
(progn
(if (= numeraz "Y")
(command "minsert" nbl t1 1 1 0 1 1 (strcat prefix (itoa number))) ;; Вставка выбранного блока в координаты узла полилинии
)
(if (= numeraz "N")
(command "minsert" nbl t1 1 1 0 1 1 "none") ;; Вставка выбранного блока в координаты узла полилинии без номера
)
(setq number (1+ number))
);end progn
); end if
); End Progn
); end if
(if (= nil tormoz)
(setq tormoz t1) ;; тормоз - координаты первого узла (чтобы не повторять)
)
; (setq number (1+ number))
) ; End progn
) ; End if
(setq n (1+ n))
) ; End while
(setq ind (1+ ind))
); End While
);End Progn
) ; End if
); End Progn
);End If
(if (= pnumer "N") ; Нумерация по одному
(progn
(setq pl (ktif-entsel
"\nВыберите полилинию:"
'("POLYLINE" "LWPOLYLINE")
""
nil
) ;_ end ktif-entsel
) ;_ end setq
(setq pl (car pl)) ;; Имя объекта (полилинии)
; (setq pl (car (entsel))) ;; Имя объекта (полилинии)
(setq plo (entget pl)) ;; Определение полилинии
;; Конец выбора полилинии
(initget 1 "Y N")
(setq numeraz (getkword "\nБудем нумеровать точки ? [Y/N]:"))
(if (= numeraz "Y")
(progn
(initget 1)
(setq number (getint "\nНачальный номер:"))
(setq prefix (vl-string-right-trim
" "
(vl-string-left-trim " " (getstring t "\nПрефикс:"))
)
)
); End Progn
) ; End if
(if (= numeraz "N")
(setq number 0)
)
(setq n 0) ;; Установка счетчика на 0
(setq tormoz nil)
(while (< n (length plo)) ;; Цикл по полилинии
(setq plo1 (nth n plo))
(setq mimo "N") ; переменная, отвечающая за пропуск уже облоченного узла
(if (= 10 (car plo1)) ;; Если запись координат
(progn
(setq t1 (cdr plo1)) ;; t1 - координаты вставки
(setq t1 (list (abs (car t1)) (abs (cadr t1)))) ;; положительные координаты вставки
;; (setq t1 (list (car t1) (cadr t1))) ;; координаты вставки Если использовать это - то расставятся блокив узлах с отрицательными коорд.
;; при вставке координат без abs не всегда проставляются точки в объектах ВИНГЕО (считается, что там X - минусовой)
(if (or (/= (car t1) (car tormoz)) (/= (cadr t1) (cadr tormoz)))
(progn
; проверка наличия блока с номером в узле полилинии
(setq c (ssget "C" (list (- (car t1) 0.01) (+ (cadr t1) 0.01)) (list (+ (car t1) 0.01) (- (cadr t1) 0.01))))
(if c
(progn
; (setq d (sslength c))
(setq ind1 0)
(while (< ind1 (sslength c))
(setq d (entget (ssname c ind1)))
(if (= "INSERT" (cdr (assoc 0 d)))
(setq mimo "Y")
);end if
(setq ind1 (+ 1 ind1))
); end while
);end progn
); end if
; конец проверки наличия блока с номером в узле полилинии
; вставка блока производится только если в узле уже нет блока
(if (= "N" mimo)
(progn
(if (= numeraz "Y")
(command "minsert" nbl t1 1 1 0 1 1 (strcat prefix (itoa number))) ;; Вставка выбранного блока в координаты узла полилинии
)
(if (= numeraz "N")
(command "minsert" nbl t1 1 1 0 1 1 "none") ;; Вставка выбранного блока в координаты узла полилинии без номера
); end if
(setq number (1+ number))
);end progn
);end if
); End Progn
)
(if (= nil tormoz)
(setq tormoz t1) ;; тормоз - координаты первого узла (чтобы не повторять)
)
; (setq number (1+ number))
) ; End progn
) ; End if
(setq n (1+ n))
) ; End while
); End Progn
); End If
)
;; Включение выравнивания
(COMMAND "OSNAP" "CENTER,NODE")
;|«Visual LISP© Format Options»
(100 2 100 2 nil "конец " 60 9 0 0 0 T T nil T)
Прога не моя, ранее была вставка в отдельный узел полилинии. Кроме того, используется процедура ktif-entsel (выбор вставляемого блока), но это достаточно несложно.
P.S. Заранее извиняюсь за возможно корявый код... как умеем (пока)
Спасибо, буду пробовать! :)
Не сработает. Код представлен не полностью.
Все работает. Для примера: в начале координат создаем блок (я предполагаю это кадастровая точка) с аттрибутом NAME и его значением 0. Для простановки в узлах рисуем полилинию и запускаем процедуру. все должно сработать (по крайней мере у меня работает в ACAD2000, 2004, 2005.Предположение, что код неполный очевидно из за ошибочной вставки двух строк после окончания процедуры.
Кроме того, используемая в коде процедура ktif-entsel заменяется командами выбора блока (SSGET) и определения его списка DXF
Вот чуть измененная и абсолютно работающая процедура расстановки блоков в узлы полилинии и их нумерации
;; Вставка блоков в узлы полилиний с их последовательной нумерацией
;; Блок должен иметь атрибут (например NAME) для нумерации. При отсутствии
;; атрибута нумерация не производится
(defun ktif-kadastr::insert-blok ( / ENAME NUMBER PREFIX
A B NBL PL PLO PLO1 N TORMOZ, NUMERAZ
ss pnumer c d mimo ind1)
;; Отмена выравнивания
(COMMAND "OSNAP" "OFF")
(prompt "\nВыберите блок для вставки...")
(setq a (ssget '((0 . "INSERT"))))
(setq a (ssname a 0))
(setq b (entget a)) ;; Определение блока - символа
(setq nbl (cdr (assoc 2 b))) ;; Наименование выбранного блока
;; Конец выбора блока для вставки
;; Выбор полилинии
(prompt "\nВыберите полигоны...")
(setq ss (ssget '((0 . "LWPOLYLINE,POLYLINE"))))
(if ss
(progn
(initget 1 "Y N")
(setq numeraz (getkword "\nБудем нумеровать точки ? [Y/N]:"))
(if (= numeraz "Y")
(progn
(initget 1)
(setq number (getint "\nНачальный номер:"))
(setq prefix (vl-string-right-trim
" "
(vl-string-left-trim " " (getstring t "\nПрефикс:"))
)
)
); End Progn
) ; End if
(if (= numeraz "N")
(setq number 0)
)
(setq ind 0)
(while (setq ename (ssname ss ind))
(setq plo (entget ename))
(setq n 0) ;; Установка счетчика на 0
(setq tormoz nil)
(while (< n (length plo)) ;; Цикл по полилинии
(setq mimo "N") ; переменная, отвечающая за пропуск уже облоченного узла
(setq plo1 (nth n plo))
(if (= 10 (car plo1)) ;; Если запись координат
(progn
(setq t1 (cdr plo1)) ;; t1 - координаты вставки
(setq t1 (list (abs (car t1)) (abs (cadr t1)))) ;; положительные координаты вставки
;; (setq t1 (list (car t1) (cadr t1))) ;; координаты вставки Если использовать это - то расставятся блокив узлах с отрицательными коорд.
;; при вставке координат без abs не всегда проставляются точки в объектах ВИНГЕО (считается, что там X - минусовой)
(if (or (/= (car t1) (car tormoz)) (/= (cadr t1) (cadr tormoz)))
(progn
; проверка наличия блока с номером в узле полилинии
(setq c (ssget "C" (list (- (car t1) 0.01) (+ (cadr t1) 0.01)) (list (+ (car t1) 0.01) (- (cadr t1) 0.01))))
(if c
(progn
(setq d (sslength c))
(setq ind1 0)
(while (< ind1 (sslength c))
(setq d (entget (ssname c ind1)))
(if (= "INSERT" (cdr (assoc 0 d)))
(setq mimo "Y")
);end if
(setq ind1 (+ 1 ind1))
); end while
);end progn
); end if
; конец проверки наличия блока с номером в узле полилинии
; вставка блока производится только если в узле уже нет блока
(if (= "N" mimo)
(progn
(if (= numeraz "Y")
(command "minsert" nbl t1 1 1 0 1 1 (strcat prefix (itoa number))) ;; Вставка выбранного блока в координаты узла полилинии
)
(if (= numeraz "N")
(command "minsert" nbl t1 1 1 0 1 1 "none") ;; Вставка выбранного блока в координаты узла полилинии без номера
)
(setq number (1+ number))
);end progn
); end if
); End Progn
); end if
(if (= nil tormoz)
(setq tormoz t1) ;; тормоз - координаты первого узла (чтобы не повторять)
)
) ; End progn
) ; End if
(setq n (1+ n))
) ; End while
(setq ind (1+ ind))
); End While
);End Progn
) ; End if
;; Включение выравнивания
(COMMAND "OSNAP" "CENTER,NODE")
)Прошу прощения за некоторое невежество, я не очень большой спец в программировании (такого рода). Какой командой вызвать процедуру?
ktif-kadastr::insert-points
Что из этого? Еще раз прошу прощения за тупость...
1.Копируете в буфер код (выделен синим) из предыдущего моего поста
2. В любом редакторе вставляете его и сохраняете в файл с расширением .lsp (например tocki.lsp)
3.Запускаете ACAD и загружаете данный файл как приложение (Инструменты - Загрузка приложения - путь к файлу - загрузить).
4.Заходите в редактор LISP (Инструменты - Autolisp - редактор VisualLisp)
5. Запускаете Visual Lisp Console и в командной строке набираете (ktif-kadastr::insert-blok)
Напоминаю, что блок должен быть создан и присутствовать на чертеже ACADa для его выбора. У меня библиотека блоков сохранена в виде файлов DWG и подгружается по мере надобности специальной процедурой.
В дальнейшем (если процедура подойдет) ее можно будет включить в меню, либо создать командную кнопку.
> Ser
Пара замечаний по коду.
1. НА русских версиях не работает.
2. Если будет выбран блок с 2 атрибутами - num и name. Какой из атрибутов будет "автонумероваться"?
3. Создал блок с 1 атрибутом (для создания "тепличных" условий коду). Запустил в английском. На первой же попытке вставки - диалоговое окно заполнения атрибута. Нажатие Esc - ошибка и вылет программы. osmode не восстановилась.
ИМХО: Доделать бы...
И вот еще. В 3DPOLYLINE, по-моему, 10 группа не описывает вершины:
_$ (setq ent (entlast)) <Entity name: 7ef7a0c8> _$ (entget (entlast)) ((-1 . <Entity name: 7ef7a0c8>) (0 . "POLYLINE") (330 . <Entity name: 7ef64cf8>) (5 . "109") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (48 . 100.0) (100 . "AcDb3dPolyline") (66 . 1) (10 0.0 0.0 0.0) (70 . 8) (40 . 0.0) (41 . 0.0) (210 0.0 0.0 1.0) (71 . 0) (72 . 0) (73 . 0) (74 . 0) (75 . 0))
А вершины таковы (код функции не показываю, он особой роли не играет)
_$ (_KPBLC-CONV-LIST-TO-3DPOINTS (vlax-safearray->list (vlax-variant-value (vla-get-coordinates (vlax-ename->vla-object ent))))) ((677.99 209.177 0.0) (623.129 274.007 0.0) (613.127 205.239 0.0) (679.203 169.188 0.0) (717.091 190.394 0.0) (712.544 134.653 0.0))
Вот еще один вариант. Запуск с ком.строки kad
(defun c:kad (/ adoc
_kpblc-get-ent-no-error-by-type
_kpblc-conv-list-to-2dpoints
_kpblc-conv-list-to-3dpoints
mark_blk num_att
tmp tmp_selset
_kpblc-block-attr-get-pointer
counter num_through
)
(defun _kpblc-block-attr-get-pointer (block tag / res)
(if
(_kpblc-is-ent-block-with-attr
(setq block (_kpblc-conv-ent-to-vla block))
) ;_ end of _kpblc-is-ent-block-with-attr
(if tag
(cond
((= (type tag) 'list)
(foreach item tag
(setq
res
(append
res
(vl-remove-if-not
'(lambda (x)
(= (strcase (vla-get-tagstring x) t) (strcase item t))
) ;_ end of lambda
(vlax-safearray->list
(vlax-variant-value (vla-getattributes block))
) ;_ end of vlax-safearray->list
) ;_ end of vl-remove-if-not
) ;_ end of append
) ;_ end of setq
) ;_ end of foreach
)
(t
(setq
res (vl-remove-if-not
'(lambda (x)
(= (strcase (vla-get-tagstring x) t) (strcase tag t))
) ;_ end of lambda
(vlax-safearray->list
(vlax-variant-value
(vla-getattributes block)
) ;_ end of vlax-variant-value
) ;_ end of vlax-safearray->list
) ;_ end of vl-remove-if-not
) ;_ end of setq
)
) ;_ end of cond
(setq res (vlax-safearray->list
(vlax-variant-value (vla-getattributes block))
) ;_ end of vlax-safearray->list
) ;_ end of setq
) ;_ end of if
) ;_ end of if
res
) ;_ end of defun
(defun _kpblc-get-ent-no-error-by-type (enttype msg / res)
(setvar "errno" 0)
(setq msg (strcat "\n"
(vl-string-trim
"\n: "
(if (not msg)
(setq msg "Выберите элемент")
msg
) ;_ end of if
) ;_ end of vl-string-trim
" <Отмена> : "
) ;_ end of strcat
) ;_ end of setq
(if (/= (type enttype) 'list)
(setq enttype (list enttype))
) ;_ end of if
(setq enttype (mapcar 'strcase enttype))
(while
(or
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(setq res (entsel msg))
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of vl-catch-all-error-p
(member (getvar "errno") '(7))
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(not
((lambda (/ in)
(foreach item enttype
(if (wcmatch (strcase (cdr (assoc 0 (entget (car res)))))
(strcase item)
) ;_ end of wcmatch
(setq in t)
) ;_ end of if
) ;_ end of foreach
in
) ;_ end of lambda
)
) ;_ end of not
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
) ;_ end of vl-catch-all-error-p
) ;_ end of or
(princ "\nОшибка выбора примитива - не тот тип")
(setvar "errno" 0)
) ;_ end of while
(if res
(list (car res) (trans (cadr res) 1 0))
) ;_ end of if
) ;_ end of defun
(defun _kpblc-conv-list-to-3dpoints (lst / res)
(cond
((not lst)
nil
)
(t
(setq res (cons (list (car lst)
(if (cadr lst)
(cadr lst)
0.
) ;_ end of if
(if (caddr lst)
(caddr lst)
0.
) ;_ end of if
) ;_ end of list
(_kpblc-conv-list-to-3dpoints (cdddr lst))
) ;_ end of cons
) ;_ end of setq
)
) ;_ end of cond
res
) ;_ end of defun
(defun _kpblc-conv-list-to-2dpoints (lst / res)
(cond
((not lst)
nil
)
(t
(setq res (cons (list (car lst)
(if (cadr lst)
(cadr lst)
0.
) ;_ end of if
) ;_ end of list
(_kpblc-conv-list-to-2dpoints (cddr lst))
) ;_ end of cons
) ;_ end of setq
)
) ;_ end of cond
res
) ;_ end of defun
(vl-load-com)
(vla-startundomark
(setq adoc (vla-get-activedocument (vlax-get-acad-object)))
) ;_ end of vla-startundomark
(if (and (setq
mark_blk
(car
(_kpblc-get-ent-no-error-by-type "INSERT" "Укажите на блок маркировки")
) ;_ end of car
) ;_ end of setq
(= (cdr (assoc 66 (entget mark_blk))) 1)
(setq num_att
(cond
((= 1
(length (vlax-safearray->list
(vlax-variant-value
(vla-getattributes
(setq mark_blk
;; В целях отладки:
(if (= (type mark_blk) 'ename)
(vlax-ename->vla-object mark_blk)
mark_blk
) ;_ end of if
) ;_ end of setq
) ;_ end of vla-GetAttributes
) ;_ end of vlax-variant-value
) ;_ end of vlax-safearray->list
) ;_ end of length
) ;_ end of =
(vla-get-tagstring
(car (vlax-safearray->list
(vlax-variant-value
(vla-getattributes
(setq mark_blk
;; В целях отладки:
(if (= (type mark_blk) 'ename)
(vlax-ename->vla-object mark_blk)
mark_blk
) ;_ end of if
) ;_ end of setq
) ;_ end of vla-GetAttributes
) ;_ end of vlax-variant-value
) ;_ end of vlax-safearray->list
) ;_ end of car
) ;_ end of vla-get-TagString
)
(t
((lambda (/ att_lst res)
(setq
att_lst (acad_strlsort
(mapcar 'vla-get-tagstring
(vlax-safearray->list
(vlax-variant-value
(vla-getattributes
(setq mark_blk
;; В целях отладки:
(if (= (type mark_blk) 'ename)
(vlax-ename->vla-object mark_blk)
mark_blk
) ;_ end of if
) ;_ end of setq
) ; _ end of
; vla-GetAttributes
) ; _ end of
; vlax-variant-value
) ; _ end of
; vlax-safearray->list
) ;_ end of mapcar
) ;_ end of acad_strlsort
) ;_ end of setq
(cond
((not
(vl-catch-all-error-p
(vl-catch-all-apply
(function
(lambda ()
(initget
((lambda (/ res)
(setq res "")
(foreach item att_lst
(setq res (strcat res " " item))
) ;_ end of foreach
(vl-string-trim " " res)
) ;_ end of lambda
)
) ;_ end of initget
(setq
res (cond
((getkword
(strcat
"Выберите атрибут для автонумерации ["
((lambda (/ res)
(setq res "")
(foreach item att_lst
(setq res (strcat res "/" item))
) ; _ end of foreach
(vl-string-trim "/" res)
) ;_ end of lambda
)
"] <"
(car att_lst)
"> : "
) ;_ end of strcat
) ;_ end of getkword
)
(t (car att_lst))
) ;_ end of cond
) ;_ end of setq
) ;_ end of lambda
) ;_ end of function
) ;_ end of vl-catch-all-apply
) ;_ end of vl-catch-all-error-p
) ;_ end of not
res
)
(t (car att_lst))
) ;_ end of cond
) ;_ end of lambda
)
)
) ;_ end of cond
) ;_ end of setq
(setq selset (ssget '((0 . "*POLYLINE"))))
(setq num_through
((lambda (/ res)
(initget "Да Нет _ Y N")
(cond
((vl-catch-all-apply
'(lambda ()
(setq
res (getkword
"Нумерация сквозная [Да/Нет] <Да> : "
) ;_ end of getkword
) ;_ end of setq
) ;_ end of lambda
) ;_ end of vl-catch-all-apply
res
)
(t "Y")
) ;_ end of cond
) ;_ end of LAMBDA
)
) ;_ end of setq
) ;_ end of and
(progn
(setq counter 0)
(foreach ent
(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr (ssnamex selset)))
) ;_ end of mapcar
(cond
((= (vla-get-objectname ent) "AcDbPolyline")
(foreach vert
(_kpblc-conv-list-to-2dpoints
(vlax-safearray->list
(vlax-variant-value (vla-get-coordinates ent))
) ;_ end of vlax-safearray->list
) ;_ end of _kpblc-conv-list-to-2dpoints
(setq tmp (if (setq tmp_selset
(ssget "_X"
(list '(0 . "INSERT")
(cons 2 (vla-get-name mark_blk))
(cons 10 vert)
) ;_ end of list
) ;_ end of ssget
) ;_ end of setq
(vlax-ename->vla-object (ssname tmp_selset 0))
(vla-insertblock
(vla-objectidtoobject adoc (vla-get-ownerid ent))
(vlax-3d-point vert)
(vla-get-name mark_blk)
1.
1.
1.
0.
) ;_ end of vla-InsertBlock
) ;_ end of if
) ;_ end of setq
(vla-put-textstring
(car (_kpblc-block-attr-get-pointer tmp num_att))
(vl-princ-to-string (setq counter (1+ counter)))
) ;_ end of vla-put-TextString
) ;_ end of foreach
)
((= (vla-get-objectname ent) "AcDb3dPolyline")
(foreach vert
(_kpblc-conv-list-to-3dpoints
(vlax-safearray->list
(vlax-variant-value (vla-get-coordinates ent))
) ;_ end of vlax-safearray->list
) ;_ end of _kpblc-conv-list-to-3dpoints
(setq tmp (if (setq tmp_selset
(ssget "_X"
(list '(0 . "INSERT")
(cons 2 (vla-get-name mark_blk))
(cons 10 vert)
) ;_ end of list
) ;_ end of ssget
) ;_ end of setq
(vlax-ename->vla-object (ssname tmp_selset 0))
(vla-insertblock
(vla-objectidtoobject adoc (vla-get-ownerid ent))
(vlax-3d-point vert)
(vla-get-name mark_blk)
1.
1.
1.
0.
) ;_ end of vla-InsertBlock
) ;_ end of if
) ;_ end of setq
(vla-put-textstring
(car (_kpblc-block-attr-get-pointer tmp num_att))
(vl-princ-to-string (setq counter (1+ counter)))
) ;_ end of vla-put-TextString
) ;_ end of foreach
)
) ;_ end of cond
(setq counter (if (= num_through "Y")
counter
0
) ;_ end of if
) ;_ end of setq
) ;_ end of foreach
) ;_ end of progn
) ;_ end of if
(vla-endundomark adoc)
(princ)
) ;_ end of defunP.S. Блок должен быть доступен для выбора. Количество атрибутов роли не играет (выполняется выбор). Слои должны быть разблокированы (контроля не выполняется). Тестировалось в пространстве модели, при мировой системе координат.
Спасибо, Ser. У меня процедура работает. Пока проверяла только на небольшом количестве узлов полилинии, работает без косяков. Возвращаясь к исходному вопросу... Можно ли мне как-то разместить блоки не в узлы полилинии, а на точечные обекты - "point" ? При оформлении топографических планов возникает задача отображения в условных знаках не только линейных и площадных элементов ситуации и рельефа, но и точечных. Например пикетов на незастроенной площади. Вставлять блок (пусть один и тот же) в каждую точку при том, что пикетов может быть за тысячу, весьма трудоемко! Нельзя ли модифицировать вашу процедуру, при способив ее к данной задаче? Или это мечты-мечты..? :)
Несмотря на оглушительную и справедливую критику уважаемого kpblc решил продолжить публиковать свои опусы... Поясняю позицию. Приводимые образчики процедур выдергиваются из эксплуатируемой в течение 3 лет системы обработки графики в целях землеустройства (в частности в ней реализованы функции построения и обработки теоходов, пикетов, формирования каталогов координат, описаний земельных участков, текстовых файлов координат, построения участков при импорте из текстовых файлов и т.д. Т.е. программы рабочие по определению. Очевидно, что там существуют какие-то упрощения, привязка к конкретной землеустроительной технологии, требованиям смежников (Кадастровой палаты, Земельных комитетов). Естественно, анализ моих корявых опусов маститыми КАДистами (это без иронии) позволит мне также в какой-то мере приобщиться к этому миру... А заодно - может кто-то найдет в них и рациональное зерно...
Итак, очередная коряга... (в комментариях вроде все описано) у меня работает.
С Уважением...
;; Процедура осуществляет вставку объекта (полилинии или окружности) в узлы другой полилинии
;; (например столбы их центрами в узлы полилинии, описывающей ЛЭП). Для корректного определения
;; центра (базовой точки) вставляемого объекта необходимо, чтобы вставляемая полилиния была
;; замкнутой (если она должна быть замкнута по определению), т.е. при рисовании столба-образца его необходимо
;; замкнуть командой CLOSE, либо отрисовать его многоугольником.
;; Суть задачи: имеется полилиния, в узлы которой необходимо втюхать однотипные объекты - любые
;; полилинии или окружности. На чертеже создается втюхиваемый образец ( в принципе любая полилиния)
;; и далее он программно центрируется и вставляется в узлы исходной полилинии.
;; Для чего ? Земельщики возможно догадаются.
(defun ktif-kadastr::insert-objekt ( / ENAME NUMBER PREFIX
A a1 B NBL PL PLO PLO1 N TORMOZ, NUMERAZ
x0 y0 t0 ts tn tnac dalse xnac ynac xn yb xs ys sppr b1 n1
coor nc out-lst st-pnt end-pnt xs-pnt ys-pnt xe-pnt ye-pnt pang pangi ugpov
stn-pnt endn-pnt clos delta)
;; Выбор блока для вставки
;; Отмена выравнивания
(COMMAND "OSNAP" "OFF")
(prompt "\nВыберите объект для вставки...")
(setq a1 (ssget))
(setq a1 (ssname a1 0))
(setq b (entget a1)) ;; Определение объекта
(if (= (cdr (nth 1 b)) "CIRCLE") ;; Если объект окружность то проще
(progn
;; Поиск центра окружности
(setq n 0)
(while (< n (length b)) ;; Цикл по полилинии
(setq b1 (nth n b))
(if (= 10 (car b1)) ;; Если запись координат
(progn
(setq t0 (cdr b1)) ;; t1 - координаты угла
;; (setq t0 (list (abs (car t0)) (abs (cadr t0)))) ;; положительные координаты вставки
(setq t1 (list (car t1) (cadr t1))) ;; координаты вставки Если использовать это - то расставятся блокив узлах с отрицательными коорд.
) ; End Progn
) ; End if
(setq n (1+ n))
) ; End while
); End Progn
); End if
(if (= (cdr (nth 1 b)) "LWPOLYLINE") ;; Если объект полилиния (любой многоугольник)
;; Поиск центра многоугольника (базовой точки)
(progn
(setq dalse 0)
(setq tnac 0)
(setq tn 0)
(setq ts 0)
(setq xnac 0)
(setq ynac 0)
(setq xn 0)
(setq yn 0)
(setq xs 0)
(setq ys 0)
(setq n 0)
(setq x0 0)
(setq y0 0)
(setq n1 0)
(while (< n (length b)) ;; Цикл по полилинии
(setq b1 (nth n b))
(if (= 10 (car b1)) ;; Если запись координат
(progn
(if (= n1 0) ;; для первой точки
(progn
(setq tnac (cdr b1)) ;; координаты первой точки
(setq xnac (car tnac))
(setq ynac (cadr tnac))
(setq x0 (+ x0 (car tnac)))
(setq y0 (+ y0 (cadr tnac)))
(setq n1 (1+ n1))
); end progn
); End if
(setq tn (cdr b1))
(setq xn (car tn))
(setq yn (cadr tn))
(if (/= dalse 0) ;; для последующих точек
(progn
(if (or (and (/= xn xnac) (/= yn ynac)) (and (/= xn xs) (/= yn ys))) ;; если координаты не равны первой или предыдущей
(progn
(setq x0 (+ x0 (car tn)))
(setq y0 (+ y0 (cadr tn)))
(setq n1 (1+ n1))
);end progn
); End if
); end progn
); end if
(setq ts tn)
(setq xs (car ts))
(setq ys (cadr ts))
(setq dalse 1)
) ; End Progn
) ; End if
(setq n (1+ n))
) ; End while
(setq x0 (/ x0 n1))
(setq y0 (/ y0 n1))
(setq t0 (list x0 y0))
); End Progn
)
;End if
;; Конец выбора объекта для вставки
(prompt "\nВыберите полилинию ...")
(setq pl (ssget '((0 . "LWPOLYLINE,POLYLINE"))))
(setq pl (ssname pl 0))
(setq plo (entget pl)) ;; Определение полилинии
;; Конец выбора полилинии
;; Формируем спосок координат coor
(setq n (length plo))
(setq nc 0)
(setq out-lst nil)
(setq coor nil)
(while (< nc n)
(setq plo1 (nth nc plo))
(if (= 10 (car plo1)) ;; Если запись координат
(progn
(setq t1 (cdr plo1)) ;; t1 - координаты вставки
;; (setq t1 (list (abs (car t1)) (abs (cadr t1)))) ;; положительные координаты вставки
(setq t1 (list (car t1) (cadr t1))) ;; координаты вставки Если использовать это - то
(setq coor (cons t1 coor))
);end progn
);end if
(setq nc(1+ nc))
);end while
(setq coor (reverse coor))
;; Конец формирования списка координат
;; На основании списка координат определяем координаты вставки, угол поворота объекта и втюхиваем объект в узел
;; (поворачиваем, копируем и разворачиваем назад)
(setq n (length coor))
(setq nc 0)
(while (< nc (- n 1))
(setq st-pnt (nth nc coor)
nc (1+ nc)
end-pnt (nth nc coor)
xs-pnt (car st-pnt)
ys-pnt (cadr st-pnt)
xe-pnt (car end-pnt)
ye-pnt (cadr end-pnt)
pang (ktif-geo:position-angle st-pnt end-pnt)
pangi (ktif-geo:position-angle end-pnt st-pnt)
) ;_ end setq
;; Анализ четверти и определение приращения
(setq delta 0)
(if (= xe-pnt xs-pnt)
(setq delta (- (/ pi 2)))
); end if
(if (and (> xe-pnt xs-pnt) (> ye-pnt ys-pnt)) ;; первая четверть
(setq delta 0)
); end if
(if (and (> xe-pnt xs-pnt) (< ye-pnt ys-pnt)) ;; вторая четверть
(setq delta (/ pi 2))
); end if
(if (and (< xe-pnt xs-pnt) (< ye-pnt ys-pnt)) ;; третья четверть
(setq delta pi)
); end if
(if (and (< xe-pnt xs-pnt) (> ye-pnt ys-pnt)) ;; четвертая четверть
(setq delta (* 1.5 pi))
); end if
(if (= ye-pnt ys-pnt)
(setq pang (+ 0 delta))
(setq pang (+ (atan (/ (abs (- xe-pnt xs-pnt)) (abs (- ye-pnt ys-pnt)))) delta))
); end if
;; конец определения приращения
(setq t1 (list xs-pnt ys-pnt))
(setq ugpov (+ (* (/ 180 pi) pang) 90))
;; Разворот выбранного объекта
(command "rotate" a1 "" t0 ugpov)
;; Копирование объекта куда нужно ( в узел полилинии)
(command "copy" a1 "" t0 t1) ;; Вставка выбранного объекта в координаты узла полилинии с центром в качестве базовой точки
;; Разворот объекта в исходное положение
(command "rotate" a1 "" t0 (- 0 ugpov))
) ; End while
;; Конец определения углов поворота и копирования
;; Включение выравнивания
(setq a1 nil)
(COMMAND "OSNAP" "CENTER,NODE")
); End defun> SvetOK
Относительно Вашей просьбы честно говоря не думал, да и не знаю как быстро это удасться. На первый взгляд, почему бы не соединить точки полилинией, расставить по узлам блоки и грохнуть полилинию. Но наверное при большом количестве точек это не вариант. Кроме того, есть у меня программка, которая строит полилинию с блоками при импорте координат из текстового файла. Посмотрю и скину, если будет время. Возможно пригодится... С Уважением...
Прошу прощения за назойливость. Относительно проставления блоков в точки попробовал следующее:
Строки
(prompt "\nВыберите полигоны...") (setq ss (ssget '((0 . "LWPOLYLINE,POLYLINE"))))
в процедуре ktif-kadastr::insert-blok (см. выше) заменил на:
(prompt "\nВыберите область точек...") (setq ss (ssget ))
Область выбирается окном и у меня проставляет блоки в точки только писк стоит.
С Ув...
Кроме того, и в линии, мнеогоугольники,даже в центры окружности и дуги (вообщем во все множество выбора). Правда сам в себя (блок в блок) еще не пробовал. Если это помогло - я рад
> Ser
А у других не будет. Не выложил ф-цию
ktif-geo:position-angle
Будет, просто не убрал ссылки на эту функцию. Закомментируйте их (PLS...)или уберите
VVA, спасибо за ссылочку. Это как раз то, что нужно для решения моей задачи! Так что,уважаемый Ser, вопрос снят. А за первую программку, которая вставляет блоки в узлы полилинии, еще раз Вам огромое спасибо!
С уважением,
Светлана.
Вот еще одна фигня...
;; Программа формирует участки (полилинии) с вставкой блоков в узлы с клавиатуры или
;; из текстового файла следующей структуры:
;; - первая строка описывающая участок - количество точек в полилинии (несущественно, лиши бы не 1-метка конца файла)
;; - смысловые строки (по количеству узлов) Номер точки пробел координата X пробел координата Y
;; - следующая строка описывающая следующий участок
;; - смысловые строки следующего участка
;; ...
;; - строка - признак конца файла - 1
;; Файл может создаваться как вручную (в любом редакторе), так и автоматом (есть прога,
;; формирующая его на основании выборки аналогичных участков)
;; В качестве блока для вставки может использоваться любой блок, с атрибутом "Номер". Блок без атрибута не нумеруется
;; и при простановке программа немного матерится, но работает. Для выбора блок должен присутствовать на чертеже
;; Количество участков и узлов полилиний - вроде бы неограничено
;; PS Ссылок на другие функции и процедуры вроде бы нет
(defun ktif-kadastr::CreatePNT (/ VIR IMFILE B SPIS N ZAP KX KY NOMER NP T1 TOCKI SPIS1
N1 ZAP1 TPOL tpol1 IZMCOOR VIB METKA TOCKI1 a b nbl)
;; Отмена выравнивания
(COMMAND "OSNAP" "OFF")
;; Выборка из файла данных и формирование списка точек
(INITGET 1 "Y N")
(SETQ VIB (GETKWORD "\nКоординаты точек будем формировать из файла ? [Y-да N-с клавиатуры ESC - выход] "))
(prompt "\nВыберите блок для вставки...")
(setq a (ssget '((0 . "INSERT"))))
(setq a (ssname a 0))
(setq b (entget a)) ;; Определение блока - символа
(setq nbl (cdr (assoc 2 b))) ;; Наименование выбранного блока
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Из файла
(IF (= "Y" VIB)
(PROGN
(setq imfile (getfiled "Выберите файл каталога координат" "C:" "" 8))
(if imfile
(progn
(INITGET 1 "Y N")
(SETQ IZMCOOR (GETKWORD "\nМенять координаты местами ? [Y/N] "))
(setq imfile (open imfile "r"))
(setq B "")
(SETQ B (READ-LINE imfile))
; (WHILE (/= B "EOF") ;; Признак конца файла (Последняя строка файла - EOF)
(WHILE (or (/= B "1") (/= (strlen B) 1)) ;; Признак конца файла (Последняя строка файла - 1)
(if (< (strlen b) 5) ;; признак начала нового полигона (строка с количеством точек)
(progn
(setq b (read-line imfile)) ;; переходим на следующую запись файла
(setq spis nil) ;; обнуляем список
(while (and (> (strlen b) 3) (/= B "1"))
(IF (and (/= B NIL) (/= b ""))
(SETQ SPIS (APPEND SPIS (LIST B)))
);; END IF
(SETQ B (READ-LINE imfile))
); end while
;; обработка списка точек и определение координат
(SETQ N 0)
(WHILE (< N (length spis)) ;; (- (LENGTH SPIS) 1))
;; хватаем строку файла и начинаем нудно посимвольно ее анализировать (помолясь...)
(SETQ ZAP (NTH N SPIS))
(SETQ NP 1)
(SETQ NOMER "")
(SETQ KX "")
(SETQ KY "")
(WHILE (< NP (+ 1 (STRLEN ZAP)))
(IF (/= 32 (ASCII (SUBSTR ZAP NP 1))) ;; Если не пробел
(progn
(IF (= "" NOMER) ;; ФОРМИРОВАНИЕ НОМЕРА ТОЧКИ
(WHILE (/= 32 (ASCII (SUBSTR ZAP NP 1)))
(SETQ NOMER (STRCAT NOMER (SUBSTR ZAP NP 1)))
(SETQ NP (+ 1 NP))
); END WHILE
) ;END IF
(IF (AND (= "" KX) (/= "" NOMER)) ;; ФОРМИРОВАНИЕ КООРДИНАТЫ Х
(WHILE (/= 32 (ASCII (SUBSTR ZAP NP 1)))
(SETQ KX (STRCAT KX (SUBSTR ZAP NP 1)))
(SETQ NP (+ 1 NP))
); END WHILE
) ;END IF
(IF (AND (= "" KY) (/= "" KX) (/= "" NOMER)) ;; ФОРМИРОВАНИЕ КООРДИНАТЫ Х
(WHILE (AND (< NP (+ 1 (STRLEN ZAP))) (/= 32 (ASCII (SUBSTR ZAP NP 1))))
(SETQ KY (STRCAT KY (SUBSTR ZAP NP 1)))
(SETQ NP (+ 1 NP))
); END WHILE
) ;END IF
) ; END PROGN
) ; END IF
(SETQ NP (+ 1 NP))
) ; END WHILE
;; вроде с одной строкой покончено, дальше - веселее
(IF (= "N" IZMCOOR)
(PROGN
(SETQ TOCKI (cons (LIST NOMER (ATOF KX) (ATOF KY)) tocki))
(SETQ T1 (LIST (ATOF KX) (ATOF KY)))
); END PROGN
); END IF
(IF (= "Y" IZMCOOR)
(PROGN
(SETQ TOCKI (cons (LIST NOMER (ATOF KY) (ATOF KX)) tocki))
(SETQ T1 (LIST (ATOF KY) (ATOF KX)))
); END PROGN
); END IF
; (if (< N (- (length spis) 1)) ;;последнюю точку не рисуем ?
(if (< N (length spis)) ;;последнюю точку рисуем ?
(command "minsert" nbl t1 1 1 0 1 1 NOMER)
)
(SETQ N (+ 1 N))
); END WHILE
;; (SETQ TOCKI (REVERSE TOCKI))
;; Формирование чистого списка координат без номера точки
(SETQ N 0)
(WHILE (< N (length TOCKI)) ;; (- (LENGTH SPIS) 1))
(SETQ ZAP (CDR (NTH N TOCKI)))
(setq TOCKI1 (cons ZAP TOCKI1))
(setq n (+ N 1))
) End While
(setq n 0)
;; Конец формирования
;; Блок отрисовки полилинии. Отдельное спасибо kpbs за решение. Раньше здесь было очень тупо
(command "_.pline")
(foreach pt TOCKI1
(command pt)
) ;_ end of foreach
(while (/= (getvar "cmdactive") 0)
(command "")
) ;_ end of while
;; Конец спасиба kpbs
(setq tocki nil)
(setq tocki1 nil)
); end progn
) ; end if
) ; END WHILE
) ;_ end PROGN
); END IF
(close imfile)
); END PROGN
); END IF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;С клавиатуры
(IF (/= "Y" VIB)
(PROGN
(SETQ B "")
(WHILE (/= "Y" VIB)
(SETQ B (GETSTRING 1 "Введите через пробел номер точки, координату Х, координату Y точки "))
(if (and (/= b nil) (/= b ""))
(SETQ SPIS (APPEND SPIS (LIST B)))
(setq vib "Y")
)
) ;END WHILE
;; обработка списка точек и определение координат (дальше все как и из файла,
;; можно сделать отдельную процеДУРУ, но лень... проще скопировал и вставил)
(SETQ N 0)
(INITGET 1 "Y N")
(SETQ IZMCOOR (GETKWORD "\nМенять координаты местами ? [Y/N] "))
(WHILE (< N (length spis)) ;; (- (LENGTH SPIS) 1))
(SETQ ZAP (NTH N SPIS))
(SETQ NP 1)
(SETQ NOMER "")
(SETQ KX "")
(SETQ KY "")
(WHILE (< NP (+ 1 (STRLEN ZAP)))
(IF (/= 32 (ASCII (SUBSTR ZAP NP 1))) ;; Если не пробел
(progn
(IF (= "" NOMER) ;; ФОРМИРОВАНИЕ НОМЕРА ТОЧКИ
(WHILE (/= 32 (ASCII (SUBSTR ZAP NP 1)))
(SETQ NOMER (STRCAT NOMER (SUBSTR ZAP NP 1)))
(SETQ NP (+ 1 NP))
); END WHILE
) ;END IF
(IF (AND (= "" KX) (/= "" NOMER)) ;; ФОРМИРОВАНИЕ КООРДИНАТЫ Х
(WHILE (/= 32 (ASCII (SUBSTR ZAP NP 1)))
(SETQ KX (STRCAT KX (SUBSTR ZAP NP 1)))
(SETQ NP (+ 1 NP))
); END WHILE
) ;END IF
(IF (AND (= "" KY) (/= "" KX) (/= "" NOMER)) ;; ФОРМИРОВАНИЕ КООРДИНАТЫ Х
(WHILE (AND (< NP (+ 1 (STRLEN ZAP))) (/= 32 (ASCII (SUBSTR ZAP NP 1))))
(SETQ KY (STRCAT KY (SUBSTR ZAP NP 1)))
(SETQ NP (+ 1 NP))
); END WHILE
) ;END IF
) ; END PROGN
) ; END IF
(SETQ NP (+ 1 NP))
) ; END WHILE
(IF (= "N" IZMCOOR)
(PROGN
(SETQ TOCKI (cons (LIST NOMER (ATOF KX) (ATOF KY)) tocki))
(SETQ T1 (LIST (ATOF KX) (ATOF KY)))
); END PROGN
); END IF
(IF (= "Y" IZMCOOR)
(PROGN
(SETQ TOCKI (cons (LIST NOMER (ATOF KY) (ATOF KX)) tocki))
(SETQ T1 (LIST (ATOF KY) (ATOF KX)))
); END PROGN
); END IF
; (if (< N (- (length spis) 1)) ;;последнюю точку не рисуем ?
(if (< N (length spis)) ;;последнюю точку рисуем ?
(command "minsert" nbl t1 1 1 0 1 1 NOMER)
)
(SETQ N (+ 1 N))
); END WHILE
;; (SETQ TOCKI (REVERSE TOCKI))
(SETQ N 0)
(WHILE (< N (length TOCKI)) ;; (- (LENGTH SPIS) 1))
(SETQ ZAP (CDR (NTH N TOCKI)))
(setq TOCKI1 (cons ZAP TOCKI1))
(setq n (+ N 1))
) End While
(setq n 0)
;; Конец формирования
;; Блок отрисовки полилинии. Отдельное спасибо kpbs за решение. Раньше здесь было очень тупо
(command "_.pline")
(foreach pt TOCKI1
(command pt)
) ;_ end of foreach
(while (/= (getvar "cmdactive") 0)
(command "")
) ;_ end of while
;; Конец вставки
(setq tocki nil)
(setq tocki1 nil)
); end progn
) ; end if
;; включаем выравнивание и вываливаемся
(COMMAND "OSNAP" "CENTER,NODE")
) ;_ end defun
Предлагаю вариант по-проще для тех, кито не шарит в ЛИСПах:
1) берем ACADMAP (желательно не ниже 2004)
2) заходим: MAP|Tools|Export|(к примеру ESRI SHAPE)и указываем к експорту объекты -> ПРАВИЛЬНО ТОЧКИ!
3) проделываем все в обратном порядке: т.е.
MAP|Tools|Import|Esri shape а в поле импорта указываем какой именно блок нада вставить вместо точек!
Чтобы отправить ответ, вы должны войти или зарегистрироваться
Форумы CADUser → Отрасль → Геодезия и картография → Автоматическая расстановка блоков на точки
Форум работает на PunBB, при поддержке Informer Technologies, Inc
