AutoCAD LISP 11
bcount.lsp = считает блоки
entlen.lsp = длины линий
gakson.LSP = аксонометрия
renumst.lsp = пере нумерация
Интеграция ArchiCAD перевод в AutoCAD индексация DWG
Архив многих LISP пол-мегабайта
http://kenokeno.ucoz.ru/dwg/LISP.rar
bcount.lsp = считает блоки
;;; COUNT.LSP
;;; Copyright © 1999 by Autodesk, Inc.
;;;
;;; Your use of this software is governed by the terms and conditions of the
;;; License Agreement you accepted prior to installation of this software.
;;; Please note that pursuant to the License Agreement for this software,
;;; "[c]opying of this computer program or its documentation except as
;;; permitted by this License is copyright infringement under the laws of
;;; your country. If you copy this computer program without permission of
;;; Autodesk, you are violating the law."
;;;
;;; AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
;;; AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
;;; MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE. AUTODESK, INC.
;;; DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
;;; UNINTERRUPTED OR ERROR FREE.
;;;
;;; Use, duplication, or disclosure by the U.S. Government is subject to
;;; restrictions set forth in FAR 52.227-19 (Commercial Computer
;;; Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
;;; (Rights in Technical Data and Computer Software), as applicable.
;;;
;;; ----------------------------------------------------------------
(defun c:bcount ( / ss flt a n lst)
(acet-error-init
(list nil T)
);acet-error-init
;build a filter of valid block names
(setq lst (acet-table-name-list (list "block" 1 4 16))) ;exclude anonymous and xref blocks
(setq n 0)
(repeat (length lst)
(setq a (nth n lst)
a (cons 2 a)
flt (cons a flt)
);setq
(setq n (+ n 1));setq
);repeat
(setq flt (append '((0 . "INSERT")
(-4 . "<OR")
)
flt
'((-4 . "OR>"))
);append
);setq
(acet-ss-clear-prev)
(princ "\nPress Enter to select all or...")
(if (setq ss (ssget))
(setq ss (ssget "_p" flt))
(setq ss (ssget "_x" flt))
);if
(if ss
(bns_count ss)
(princ "\nNo valid objects selected.")
);if
(acet-error-restore)
);defun c:count
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bns_count ( ss / bna lst na e1 n a mx )
;get a list of all unique block names
(setq mx 1)
(setq n 0)
(repeat (sslength ss)
(setq na (ssname ss n)
e1 (entget na)
bna (cdr (assoc 2 e1))
mx (max mx (strlen bna))
);setq
(if (not (assoc bna lst))
(setq lst (cons (cons bna 1) lst))
(setq a (cdr (assoc bna lst))
a (+ a 1)
lst (subst (cons bna a) (assoc bna lst) lst)
);setq
);if
(setq n (+ n 1));setq
);repeat
(if lst
(progn
(setq mx (+ mx 5));setq
(princ (bns_count_format "Block" "Count" mx))
(setq a "\n")
(while (< (strlen a) (+ mx 7))
;; (setq a (strcat a "-"))
(setq a (acet-str-format "%1-" a))
);while
(princ a)
);progn then print header
);if
(setq n 0)
(repeat (length lst)
(setq a (nth n lst));setq
(princ (bns_count_format (car a) (itoa (cdr a)) mx))
(setq n (+ n 1));setq
);repeat
);defun bns_count
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bns_count_format ( a b mx / )
(while (<= (strlen a) mx)
;; (setq a (strcat a "."))
(setq a (acet-str-format "%1." a))
);while
;; (setq a (strcat "\n" a b))
(setq a (acet-str-format "\n%1%2" a b))
);defun bns_count_format
(princ)
entlen.lsp = длины линий
;======================================================================
;entLen_moss.lsp — Подсчёт суммы длин выбранных примитивов
;Моя корректировка программы entLen взятой по URL'у:
;http://www.autocad.ru/cgi-bin/f1/board.cgi?t=21732rf
;======================================================================
(vl-load-com)
(defun C:ENTLEN (/
NABOR ;Набор примитивов
i ;Счётчик
ENT_i ;i-й примитив из набора NABOR
LEN_all ;Суммарная длина примитивов
LEN_i ;Длина i-го примитива
)
(princ "\nПодсчёт суммы длин выбранных примитивов. ")
(princ "\nВыберите примитивы: ")
;--------------------------------------------------------------------
;Выбор примитивов [выбираем нужные, отфильтровываем ненужные]
;--------------------------------------------------------------------
(setq NABOR (ssget
'((-4 . "<OR")
(0 . "*LINE")
(0 . "CIRCLE")
(0 . "ARC")
(0 . "ELLIPSE")
(-4 . "OR>")
)
);end ssget
);end setq
;--------------------------------------------------------------------
;Сообщение о количестве выбранных примитивов
;--------------------------------------------------------------------
(princ (strcat "\nВсего выбрано примитивов: " (itoa (sslength NABOR))))
(princ "\n-------------------------")
;--------------------------------------------------------------------
;Установка начальных значений
;--------------------------------------------------------------------
(setq i 0)
(setq LEN_all 0.0)
;--------------------------------------------------------------------
;Цикл по набору NABOR
;--------------------------------------------------------------------
(while (< i (sslength NABOR))
;..................................................................
;Определяем Имя i-го примитива из набора NABOR
;..................................................................
(setq ENT_i (ssname NABOR i))
;..................................................................
;Определяем Длиу i-го примитива из набора NABOR
;..................................................................
(setq LEN_i (vlax-curve-getDistAtParam
(vlax-ename->vla-object ENT_i)
(vlax-curve-getEndParam ENT_i)
);end vlax-curve-getDistAtParam
);end setq
(princ (strcat "\n"(itoa (1+ i)) "-й примитив = " (rtos LEN_i) "м"))
;;;Отладка
;;;(redraw ENT_i 3)
;;;(read-line)
;..................................................................
;Наращиваем суммарную длину всех выбранных примитивов
;..................................................................
(setq LEN_all (+ LEN_all LEN_i))
(setq i (1+ i))
);end while
(princ "\n-------------------------")
(princ (strcat
"\nОбщая длина " (itoa (sslength NABOR)) " выбранных примитивов = "
(rtos LEN_all)
"м"
);end strcat
);end princ
(prin1)
);end defun C:ENTLEN
;**********************************************************************
gakson.LSP = аксонометрия
;|
Psevdo-Aksonometr gorizontal ver 3.3
All rights reserved including right of reproduction in whole or in part in ang form.
Перевод прямоугольного чертежа (плана) из плоскости "XY <90" в псевдоаксонометрическую
плоскость "XY <45" (сантехническая аксонометрия), при этом угол может быть задан
от 0 до 90 градусов считая от положительного направления оси Х против часовой стрелки.
ВНИМАНИЕ:
программа работает только для следующих типов объектов:
- линия "LINE" (правильная работа гарантируется)
- дуга "ARC"
- полилиния "LWPOLYLINE" без криволинейных сегментов
- круг "CIRCLE" (пересчет в эллипс)
- прямоугольник "RECTANGLE" (также, как и полилиния)
- многоугольник "POLYGON" (также, как и полилиния)
- текст "TEXT", "MTEXT" (перемещение без поворота)
ИСХОДНЫЕ ОБЪЕКТЫ НЕ СОХРАНЯЮТСЯ (апгрейдятся они :)
Планируется сделать пересчет для:
- фигура "SOLID"
- полоса "TRACE"
- кольцо "DONUT"
- блок "INSERT"
!!! ВСЕ ДРУГИЕ ОБЪЕКЫ БУДУТ ИГНОРИРОВАТЬСЯ !!!
ПРИМЕР:
Command: gakson
ПРОГРАММА ПЕРЕВОДА ПЛАНА В АКСОНОМЕТРИЧЕСКУЮ ПРОЕКЦИЮ.
Выберите объекты:
Select objects: Specify opposite corner: 13 found
Select objects:
Введите угол в градусах (от 0 до 90), <45>: 60
Укажите точку поворота :
0
(к этому моменту все указанные выше объекты уже перестроены в аксонометрию)
Command:
|;
(defun C:gakson ( / *error*)
(setq p_cmdecho (getvar "CMDECHO")
p_snapmode (getvar "SNAPMODE")
p_orthomode (getvar "ORTHOMODE")
p_blipmode (getvar "BLIPMODE")
p_osmode (getvar "OSMODE")
)
(defun *error* (msg) ; Переопределение функции ERROR
(princ "Программа прервана пользователем")
(setvar "SNAPMODE" p_snapmode)
(setvar "ORTHOMODE" p_orthomode)
(setvar "BLIPMODE" p_blipmode)
(setvar "OSMODE" p_osmode)
(setvar "CMDECHO" p_cmdecho)
; (setvar "ERRNO" 0)
(setq p_cmdecho nil p_snapmode nil p_orthomode nil p_osmode nil p_blipmode nil)
; (princ "\n END with ERROR")
(princ)
) ; defun(*error*)
(setvar "CMDECHO" 0)
(setvar "SNAPMODE" 0)
(setvar "ORTHOMODE" 0)
(setvar "BLIPMODE" 0)
(setvar "OSMODE" 1)
(gc)
(setq stangle nil stangle1 nil endangle nil endangle1 nil bit10 nil bit10new nil
bit11 nil bit11new nil bit50 nil bit50new nil bit51 nil bit51new nil object_new nil)
(setq n 0 nabr nil number 0 name nil processed_obj 0)
(princ "\n ПРОГРАММА ПЕРЕВОДА ПЛАНА В АКСОНОМЕТРИЧЕСКУЮ ПРОЕКЦИЮ.")
(princ "\n Выберите объекты: ")
(setq nabr (ssget))
(setq number (sslength nabr))
(initget 6)
(setq ugol (getreal "\n Введите угол в градусах (от 0 до 90), <45>: "))
(if (null ugol) (setq ugol 45.0))
(setq ugolrad (* pi (/ ugol 180.0)))
(setq point (getpoint "\n Укажите точку поворота : ")
x0 (car point)
y0 (cadr point)
)
(princ "\n")
(setvar "OSMODE" 0)
(while (> number n)
(setq name (ssname nabr n))
(setq object (entget name))
(setq klass (cdr (assoc 0 object)))
(if (= (cdr (assoc 70 (tblsearch "LAYER" (cdr (assoc 8 object))))) 4) ; бит 4 - слой заблокирован (проверять для каждой версии AutoCAD'a)
(vl-cmdf "_.-layer" "_U" (cdr (assoc 8 object)) "")
)
; разделение по типам объектов
(cond
;;;----- Обработка примитивов типа "LINE", пересчет координат вершин
((eq klass "LINE")
(setq bit10 (assoc 10 object)
bit11 (assoc 11 object)
x1 (cadr bit10)
y1 (caddr bit10)
z1 (cadddr bit10)
x2 (cadr bit11)
y2 (caddr bit11)
z2 (cadddr bit11)
x1n (+ (* (- y1 y0) (cos ugolrad)) x1)
y1n (+ (* (- y1 y0) (sin ugolrad)) y0)
x2n (+ (* (- y2 y0) (cos ugolrad)) x2)
y2n (+ (* (- y2 y0) (sin ugolrad)) y0)
bit10new (list 10 x1n y1n z1)
bit11new (list 11 x2n y2n z2)
object_new (subst bit10new bit10 object)
object_new (subst bit11new bit11 object_new)
processed_obj (1+ processed_obj)
)
(entmod object_new)
(entupd name)
) ; equal klass "LINE"
;;;----- Обработка примитивов типа "LWPOLYLINE", пересчет координат вершин
((eq klass "LWPOLYLINE")
(foreach item object ; выбор из описания полилинии координат вершин
(if (= (car item) 10)
(setq coords (cons item coords))
)
)
(setq vertex (length coords) num_ver 0 object_new object)
(while (> vertex num_ver)
(setq bit10 (nth num_ver coords)
x1 (cadr bit10)
y1 (caddr bit10)
x1n (+ (* (- y1 y0) (cos ugolrad)) x1)
y1n (+ (* (- y1 y0) (sin ugolrad)) y0)
bit10new (list 10 x1n y1n)
object_new (subst bit10new bit10 object_new)
)
(setq num_ver (1+ num_ver))
) ; while(vertex>num_ver)
(entmod object_new)
(entupd name)
(setq processed_obj (1+ processed_obj) coords nil vertex nil)
) ; equal klass "LWPOLYLINE"
;;;----- Обработка примитивов типа "CIRCLE", пересчет координат центра
;;; для преобразования окружности в эллипс используется коэффициенты (эмпирические):
;;; Rmin/Rmax=-0,0000000000943901414007017*ugol^4+0,000000567997308646077*ugol^3-0,0000362793934898559*ugol^2+0,00997592958744082*ugol-0,0128148277900414
;;; Rmax/Rокр=0,000000000310680082815694*ugol^4+0,00000000353048189760587*ugol^3-0,0000539963966370921*ugol^2+0,00000236411058931183*ugol+1,41420291881995
((eq klass "CIRCLE")
(setq bit8 (assoc 8 object) ; слой объекта
bit10 (assoc 10 object) ; координаты центра окружности
bit40 (assoc 40 object) ; радиус окружности
bit67 (assoc 67 object) ; пространство модель/лист
bit410 (assoc 410 object) ; имя пространства
x1 (cadr bit10)
y1 (caddr bit10)
z1 (cadddr bit10)
radius (cdr bit40)
x1n (+ (* (- y1 y0) (cos ugolrad)) x1)
y1n (+ (* (- y1 y0) (sin ugolrad)) y0)
)
(if (= ugol 45.0)
(setq radiuscoeff (/ 54.11961001 130.65629649)
Rmaxcoeff (/ 130.65629649 100.0)
)
(setq radiuscoeff (- (+ (* 0.000000567997308646077 (expt ugol 3.0)) (* 0.00997592958744082 ugol)) (* 0.0000000000943901414007017 (expt ugol 4.0)) (* 0.0000362793934898559 (expt ugol 2.0)) 0.0128148277900414)
Rmaxcoeff (- (+ (* 0.000000000310680082815694 (expt ugol 4.0)) (* 0.00000000353048189760587 (expt ugol 3.0)) (* 0.00000236411058931183 ugol) 1.41420291881995) (* 0.0000539963966370921 (expt ugol 2.0)))
)
)
(setq Xbit11 (* Rmaxcoeff radius (cos (* pi (/ ugol 360.0))))
Ybit11 (* Rmaxcoeff radius (sin (* pi (/ ugol 360.0))))
bit10new (list 10 x1n y1n z1)
bit11new (list 11 Xbit11 Ybit11 z1)
bit40new (cons 40 radiuscoeff)
bit42new (cons 42 (* pi 2.0))
processed_obj (1+ processed_obj)
)
(entmakex (list '(0 . "ELLIPSE") '(100 . "AcDbEntity") bit67 bit410 bit8
'(100 . "AcDbEllipse") bit10new bit11new '(210 0.0 0.0 1.0)
bit40new '(41 . 0.0) bit42new))
(entdel name)
) ; equal klass "CIRCLE"
;;;----- Обработка примитивов типа "ARC", пересчет координат центра и вершин
((eq klass "ARC")
(setq bit8 (assoc 8 object) ; слой объекта
bit10 (assoc 10 object) ; координаты центра дуги
bit40 (assoc 40 object) ; радиус дуги
bit50 (assoc 50 object) ; начальный угол (радианы)
bit51 (assoc 51 object) ; конечный угол (радианы)
bit67 (assoc 67 object) ; пространство модель/лист
bit410 (assoc 410 object) ; имя пространства
x1 (cadr bit10)
y1 (caddr bit10)
z1 (cadddr bit10)
radius (cdr bit40)
stangle (cdr bit50)
endangle (cdr bit51)
x1n (+ (* (- y1 y0) (cos ugolrad)) x1)
y1n (+ (* (- y1 y0) (sin ugolrad)) y0)
chetv (* pi (/ 90.0 180.0))
eighth (* pi (/ ugol 360.0))
)
(if (and (>= stangle 0.0) (< stangle (* pi 0.5)))
(setq stangle1 (- (- stangle (* pi (/ ugol 360.0))) (* (- chetv ugolrad) (/ (- stangle (* pi (/ ugol 360.0))) chetv))))) ; if для I четверти
(if (and (>= endangle 0.0) (<= endangle (* pi 0.5)))
(setq endangle1 (- (- endangle (* pi (/ ugol 360.0))) (* (- chetv ugolrad) (/ (- endangle (* pi (/ ugol 360.0))) chetv))))) ; if для I четверти
(if (and (>= stangle (* pi 0.5)) (< stangle pi))
(setq stangle1 (- stangle (* (- chetv ugolrad) (- 2.0 (/ stangle chetv)))))) ; if для II четверти
(if (and (>= endangle (* pi 0.5)) (< endangle pi))
(setq endangle1 (- endangle (* (- chetv ugolrad) (- 2.0 (/ endangle chetv)))))) ; if для II четверти
(if (and (>= stangle pi) (< stangle (* pi 1.5)))
(setq stangle1 (- stangle (* (- chetv ugolrad) (- (/ stangle chetv) 2.0))))) ; if для III четверти
(if (and (>= endangle pi) (< endangle (* pi 1.5)))
(setq endangle1 (- endangle (* (- chetv ugolrad) (- (/ endangle chetv) 2.0))))) ; if для III четверти
(if (and (>= stangle (* pi 1.5)) (< stangle (* pi 2.0)))
(setq stangle1 (- stangle (* (- chetv ugolrad) (- 4.0 (/ stangle chetv)))))) ; if для IV четверти
(if (and (>= endangle (* pi 1.5)) (< endangle (* pi 2.0)))
(setq endangle1 (- endangle (* (- chetv ugolrad) (- 4.0 (/ endangle chetv)))))) ; if для IV четверти
(if (= ugol 45.0)
(setq radiuscoeff (/ 54.11961001 130.65629649)
Rmaxcoeff (/ 130.65629649 100.0)
)
(setq radiuscoeff (- (+ (* 0.000000567997308646077 (expt ugol 3.0)) (* 0.00997592958744082 ugol)) (* 0.0000000000943901414007017 (expt ugol 4.0)) (* 0.0000362793934898559 (expt ugol 2.0)) 0.0128148277900414)
Rmaxcoeff (- (+ (* 0.000000000310680082815694 (expt ugol 4.0)) (* 0.00000000353048189760587 (expt ugol 3.0)) (* 0.00000236411058931183 ugol) 1.41420291881995) (* 0.0000539963966370921 (expt ugol 2.0)))
)
)
(setq Xbit11 (* Rmaxcoeff radius (cos (* pi (/ ugol 360.0))))
Ybit11 (* Rmaxcoeff radius (sin (* pi (/ ugol 360.0))))
bit10new (list 10 x1n y1n z1)
bit11new (list 11 Xbit11 Ybit11 z1)
bit40new (cons 40 radiuscoeff)
bit41new (cons 41 stangle1)
bit42new (cons 42 endangle1)
processed_obj (1+ processed_obj)
)
(entmakex (list '(0 . "ELLIPSE") '(100 . "AcDbEntity") bit67 bit410 bit8
'(100 . "AcDbEllipse") bit10new bit11new '(210 0.0 0.0 1.0)
bit40new bit41new bit42new))
(entdel name)
) ; equal klass "ARC"
;;;----- Обработка примитивов типа "*TEXT" и "POINT", пересчет координат точки вставки
((member klass '("TEXT" "MTEXT" "POINT"))
(setq bit10 (assoc 10 object)
x1 (cadr bit10)
y1 (caddr bit10)
z1 (cadddr bit10)
x1n (+ (* (- y1 y0) (cos ugolrad)) x1)
y1n (+ (* (- y1 y0) (sin ugolrad)) y0)
bit10new (list 10 x1n y1n z1)
object_new (subst bit10new bit10 object)
processed_obj (1+ processed_obj)
)
(entmod object_new)
(entupd name)
) ; member klass "*TEXT" "POINT"
) ; cond
(setq n (+ n 1))
) ;while(main)
(if (/= n processed_obj)
(princ (strcat "\n Не удалось обработать объектов: " (rtos (- n processed_obj) 2 0) ".\n"))
)
(setvar "SNAPMODE" p_snapmode)
(setvar "ORTHOMODE" p_orthomode)
(setvar "BLIPMODE" p_blipmode)
(setvar "OSMODE" p_osmode)
(setvar "CMDECHO" p_cmdecho)
; (setvar "ERRNO" 0)
) ; defun
renumst.lsp = пере нумерация
;; renumst.lsp
;; версия 1.2
;; 8/24/10
;; fixo () 2010 * all rights released
;; программа перенумерации (только для подчеркнутого текста)
(defun C:RENUMST (/ *error* elist en lname lock lrlist ltbr match rate ss start state txt)
(defun *error* ( msg )
(command "_.undo" "_end")
(if msg
(or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
(princ (strcat "\n** Error: " msg " **")))
)
(command)
(princ)
)
(setq lname (getstring "\nВведите имя слоя текста <Стыки>: "))
(if (eq "" lname)(setq lname "Стыки"))
(setq ltbr (tblobjname "layer" lname)
lrlist(entget ltbr)
)
(setq state (cdr (assoc 70 lrlist)))
(if (not (zerop state))
(progn
(setq lock T)
(entmod (subst (cons 70 0)(assoc 70 lrlist) lrlist)))
)
(initget 7)
(setq start (getint "\nВведите стартовый номер : "))
(if (setq ss (ssget (list (cons 0 "TEXT")(cons 1 "%%U*")(cons 8 lname))))
(progn
(initget 2)
(setq rate (getint "\nВведите шаг (используйте минус для понижения нумерации) <1>: "))
(if (not rate)(setq rate 1))
(command "_.undo" "_begin")
(while
(setq en (ssname ss 0))
(setq elist (entget en))
(setq txt (cdr (assoc 1 elist)))
(setq match (atoi (vl-string-subst "" "%%U" txt)))
(if (>= match start)
(progn
(setq txt (strcat "%%U" (itoa (+ rate (atoi (vl-string-subst "" "%%U" txt))))))
(entmod (subst (cons 1 txt) (assoc 1 elist) elist))
(entupd en)
)
)
(ssdel en ss)
)
)
)
(if (and state lock)
(entmod (subst (cons 70 state)(assoc 70 lrlist) lrlist))
)
(*error* nil)
(princ)
)
(princ "\n == Программа перенумерации текста загружена ==")
(princ "\n = [Только для почеркнутых однострочных тестов] =")
(prompt "\n *** Для выполнения введите RENUMST ***")
(prin1)
|
