 |
|
|
;* (наименование и назначение программы)
;* (версия Acad)
;* (автор и его координаты, Email, сайт и пр.)
;* ABC_FUNCTION.LSP (FAS) [Файл общих функций к программам семейства ABC*]
;*
;* Это пример организации и оформления программ по стандарту KAI.
;
;* ** Acad 15,16,17
;* ** (c) Косов А.И., г.Магадан, тел.(413-2)65-05-10д http://geol-dh.narod.ru/ ai_kosov@mail.ru
;* ** 2003 г
;
;список функций пользователя данного файла
; ABC_UNLOCK_LAYER
; ABC_RTOD
; ABC_DTOR
; ABC_REGISTER_APP
; ABC_UNLOCK_LAYER
; ABC_CHECK_OBTYPE
; ABC_TSTYLE_LIST
; ABC_LAYER_LIST
; ABC_FILL_COLOR
; ABC_GETINDEX
; ABC_DIG2STR_COLOR
; ABC_HELP
; ABC_MES
; ABC_SAVE_SVAR
; ABC_RESTORE_SVAR
; ABC_LOGPROG
;
;
;-----------------------------------------------------------------------------------------------------------------
; Функция проверки слоя на замкнутость, отмыкание его и добавления имени этого слоя в строку (разделитель запятая)
;-----------------------------------------------------------------------------------------------------------------
(defun ABC_UNLOCK_LAYER (layname lockstr / )
;layname - имя слоя для проверки, размыкания и добавления в строку
;lockstr - строка с именами слоев (замкнутых)
(if (not (zerop (logand (cdr (assoc 70 (tblsearch "LAYER" layname))) 4)))
(progn
;размыкание слоя
(command "._-LAYER" "_Unlock" layname "")
;добавление имени слоя в строку с разделителями
(if (/= lockstr "")
(setq lockstr (strcat lockstr "," layname))
(setq lockstr (strcat lockstr layname))
)
)
)
; строка с именами замкнутых слоев через запятую типа: "0,Layer1,LayerN,...."
lockstr
);end of ******* ABC_UNLOCK_LAYER ********
;
;------------------------------------------
; Функция преобразования радианов в градусы
;------------------------------------------
(defun ABC_RTOD (a)
;a - угол в радианах
(setq err$ "RTOD")
(/ (* a 180.0) PI); возвращает угол в градусах
);end of **** ABC_RTOD ******
;
;------------------------------------------
; Функция преобразования градусов в радианы
;------------------------------------------
(defun ABC_DTOR (a)
;а - угол в градусах
(setq err$ "DTOR")
(* PI (/ a 180.0)); возвращает угол в радианах
);end of **** ABC_DTOR ******
;
;-----------------------------------------------------
; Функция регистрации программы для расширенных данных
;-----------------------------------------------------
(defun ABC_REGISTER_APP (appname / reg) ;Extended data
(setq reg T)
(if (tblsearch "APPID" appname)
(setq reg reg);просто для соблюдения условия T
(if (= (regapp appname) nil)
(progn
(princ (strcat "\n" "Can't register XDATA for" " " appname))
(alert (strcat "Can't register XDATA for" " " appname ))
(setq reg nil)
)
)
)
; выход T если успешно и nil в противном случае
reg
);end of ********** ABC_REGISTER_APP *******
;
;
;-----------------------------------------------------------------------------------------------------------------
; Функция проверки слоя на замкнутость, отмыкание его и добавления имени этого слоя в строку (разделитель запятая)
;-----------------------------------------------------------------------------------------------------------------
(defun ABC_UNLOCK_LAYER (layname lockstr / )
;layname - имя слоя для проверки, размыкания и добавления в строку
;lockstr - строка с именами слоев (замкнутых)
(if (not (zerop (logand (cdr (assoc 70 (tblsearch "LAYER" layname))) 4)))
(progn
;размыкание слоя
(command "._-LAYER" "_Unlock" layname "")
;добавление имени слоя в строку с разделителями
(if (/= lockstr "")
(setq lockstr (strcat lockstr "," layname))
(setq lockstr (strcat lockstr layname))
)
)
)
; строка с именами замкнутых слоев через запятую типа: "0,Layer1,LayerN,...."
lockstr
);end of ******* ABC_UNLOCK_LAYER ********
;
;--------------------------------------------------------
; Функция проверки допустимости типа объекта по его имени
;--------------------------------------------------------
(defun ABC_CHECK_OBTYPE (en name_list / name str true)
;en - entname
;name_list - список допустимых имен объектов в формате:
; ("NAME1" "NAME2" ... "NAMEn"), например: ("LINE" "POLYLINE")
(setq name (cdr (assoc 0 (entget en))))
(setq str "")
(foreach n name_list
(if (= name n)
(setq true T)
)
(setq str (strcat str ", " n))
);foreach
(if (not true)
(alert (strcat "Оbject selected" ": " name ".\n\n"
"Allowed" ": " (substr str 3 (strlen str))
))
)
;возвращает T если объект допустимый, иначе - nil
true
);end of ******* ABC_CHECK_OBTYPE *********
;
;---------------------------------------------------------------------------------------------
; Функция составления списка стилей текста ТОЛЬКО с переменной высотой (40 /= 0) и не пустых
;---------------------------------------------------------------------------------------------
(defun ABC_TSTYLE_LIST ( / sortlist templist name)
(setq templist (tblnext "STYLE" T)); вызываем список данных 1 стиля текста из таблицы стилей
(while templist
(setq name (strcase (cdr (assoc 2 templist))))
(if (not (or (/= (cdr (assoc 40 templist)) 0.0) (= name "")))
;собираем в список не пустые имена стилей текста и только с переменной высотой
(setq sortlist (cons name sortlist))
)
(setq templist (tblnext "STYLE")); список следующего стиля в таблице
);while
(if (>= (getvar "MAXSORT") (length sortlist))
(setq sortlist (acad_strlsort sortlist))
(alert (strcat "To sort styles name set sysvar value 'MAXSORT' more then" ": " (itoa (length sortlist))))
)
; выход - отсортированный список стилей текста с переменной высотой или NIL если список не создан
sortlist;типа: ("0" "STYLE-1" .... "STYLE-N")
);end of ******* ABC_TSTYLE_LIST **********
;
;--------------------------------------------------------------------
; Функция составления списка слоев у которых биты группы 70 не заданы
;--------------------------------------------------------------------
(defun ABC_LAYER_LIST (flag / sortlist templist name)
;flag - выражение типа (+ 1 2 4 16 32), где цифры - биты (1 и 2 - замороженные, 4 - замкнутые, 16 и 32 - xref)
(setq templist (tblnext "LAYER" T)); вызываем список данных 1 слоя из таблицы слоев
(while templist
(setq name (strcase (cdr (assoc 2 templist))))
(if (and (zerop (logand (cdr (assoc 70 templist)) flag)) (/= name ""))
;собираем в список не пустые слои, а также
;(не Xref, не замороженые, не запертые и т.д., в зависимости от того
;какое значение флага передается в функцию)
(setq sortlist (cons name sortlist))
)
(setq templist (tblnext "LAYER")); список следующего слоя в таблице
);while
(if (>= (getvar "maxsort") (length sortlist))
(setq sortlist (acad_strlsort sortlist));сотрировка по авфавиту
(alert (strcat "To sort layers name set sysvar value 'MAXSORT' more then" ": " (itoa (length sortlist))))
)
; выход - отсортированный список нужных слоев слоев или NIL если список не создан
sortlist;типа: ("0" "LAYER-1" .... "LAYER-N")
);end of ********* ABC_LAYER_LIST *********
;
;--------------------------------------------------------------------------------------------------------------
; Функция вызова станартного окна Acad для задания цвета и меняющая цвет имиджа в окне задания параметров (DCL)
;--------------------------------------------------------------------------------------------------------------
(defun ABC_FILL_COLOR (flagwindow colnum tile / num width heigth)
;flagwindow - если = "YES" вызывается окно Acad для задания цвета
;colnum - [integer] номер цвета от 0 до 256 (вкл.) 0-ByBlock, 256-ByLayer
;tile - [string] имя поля (цветного прямоуголькика) в DCL
(if (or (< colnum 0) (> colnum 256));проверяем диапазон цветов
(setq colnum 256);по слою
)
; вызов стандартного окна Acad для задания цвета, если задан его вывод при вызове функции (параметр flagwindow)
(if (and (= flagwindow "YES") (setq num (acad_colordlg colnum 1)))
(setq colnum num)
)
(setq width (dimx_tile tile);считывание размера будущего цветного имиджа
height (dimy_tile tile))
(start_image tile)
(fill_image 0 0 width height colnum) ;заполнение цветом прямоугольника
(end_image)
(set_tile tile (strcat " " (itoa colnum))) ;отрисовка цифры цвета на цветном имидже
; возврат - номер цвета [integer]
colnum
);end of ********* $_FILL_COLOR ***********
;
;----------------------------------------------------------------------------------------
;функция возврата порядкового номера в списке по его значению (для обработки списков DCL)
;----------------------------------------------------------------------------------------
(defun ABC_GETINDEX (item itemlist / m n)
;item - порядковый член списка (начиная с нуля)
;itemlist - список
(setq n (length itemlist))
(if (> (setq m (length (member item itemlist))) 0)
(- n m)
nil
)
;возвращает порядковый номер члена в списке или nil если его нет в списке
);end of ** ABC_GETINDEX **
;
;---------------------------------------------------
; функция возврата цвета Acad (строки) по его номеру
;---------------------------------------------------
(defun ABC_DIG2STR_COLOR (digcol / chcol)
;digcol - (integer) номер цвета от 0-256 включ.
;если что-то другое (строка, список, real, отрицательное число) - возврат все-равно "ByLayer"
(cond ((/= (type digcol) 'INT) (setq chcol "BYLAYER"))
((= digcol 0) (setq chcol "BYBLOCK"))
((= digcol 1) (setq chcol "RED"))
((= digcol 2) (setq chcol "YELLOW"))
((= digcol 3) (setq chcol "GREEN"))
((= digcol 4) (setq chcol "CYAN"))
((= digcol 5) (setq chcol "BLUE"))
((= digcol 6) (setq chcol "MAGENTA"))
((= digcol 7) (setq chcol "WHITE"))
((and (> digcol 7) (< digcol 256))
(setq chcol (itoa digcol)))
(T (setq chcol "BYLAYER"))
)
;возврат: строка с именем (или номером) цвета, или "ByLayer",
; если входной параметр выходит за пределы цветов Acad
) ; end of *** ABC_DIG2STR_COLOR ***
;
;--------------------------------------------------------------------
;Пример функции вызова справки к программе, стандартного Windows Help
;--------------------------------------------------------------------
(defun ABC_HELP (index / )
;index - (STRING) индекс в WinHelp. Значение строки индекса странички помощи к данной программе.
; Значение индекса, как правило, задается по имени программы (для удобства)
(if (findfile "ABC_HELP.HLP");файл WinHelp
;вызов странички из файла ABC_HELP.HLP по данному интексу.
;если таковой индекс не определен, вызывается страничка по умолчанию или первая в файле справки
(help "ABC_HELP" index)
;Сообщение для пользователя, если не найден файл
(alert (strcat "\n ABC_HELP.hlp." " Help file not found. "))
)
;возврат - нет
) ;end *** ABC_HELP ******
;
;----------------------------------------------------------------------------
;Функция вывода строки текста по его номеру в списке и заданному номеру языка
;----------------------------------------------------------------------------
(defun ABC_MES (num / mes2)
;num =номер сообщения (int)
;предварительно, например из файла параметров, должны быть загружены следующие переменные:
;
;abc_mesage_list = список сообщений типа: (список задается в файле SET для каждой программы)
; '((0 "Massage_0" "Сообщение_0")
; (1 "Massage_1" "Сообщение_1")
; (2 "Massage_2" "Сообщение_2")) и т.д. (порядковые номера должны быть строко по порядку, начиная с 0)
;abc_language = номер языка сообщений, например: 1 - English 2 - Русский
; (задается в файле SET или любом автоматически исполняемом файле при загрузке чертежа Acad
; и, как правило, глобальной переменной для всех программ ABC)
;
(if abc_mesage_list ; а вдруг не загружен список сообщений из файла SET?
(if (setq mes2 (nth num abc_mesage_list)) ;список по номеру сообщения, типа (1 "Massage_1" "Сообщение_1")
(setq mes2 (nth abc_language mes2))
)
)
;проверяем сначала, а вдруг не загружен список сообщений из файла SET? Если список=nil Acad возвратит ошибку на ntn.
;находим сначала список типа (1 "Massage_1" "Сообщение_1") по номеру num=1,
;и затем по заданному номеру языка и само сообщение
;на соответствие типов и пустой список не проверяем (т.к., сами его назначаем и заполняем.)
(if (and abc_mesage_list (setq mes2 (nth abc_language (nth num abc_mesage_list))))
(setq mes2 mes2); возвращаемое значение при успехе
(progn
(alert (strcat (itoa num) "\n" "Message not found."));предупреждение пользователю
(setq mes2 "_?_"); возвращаемое значение при неудаче
)
)
;вывод функции - строка сообщения на нужном языке типа "Сообщение_1"
);end of **** ABC_MES *****
;
;--------------------------------------------------------------------------------------------------------
;Функция сохранения текущих значений системных переменных (вызывается, обычно, в начале работы программы)
;--------------------------------------------------------------------------------------------------------
(defun ABC_SAVE_SVAR (svar_list / saved_svar_list errstr val)
;параметр функции svar_list = '("SYSVAR_NAME_1" "SYSVAR_NAME_2"....."SYSVAR_NAME_n"),
; список системных переменных (строки)
;пример вызова функции: (setq saved_svar_list (ABC_SAVE_SVAR '("CMDECHO" "BLIPMODE" "FILLETRAD")))
(setq errstr "")
(foreach n svar_list
(if (setq val (getvar n))
(setq saved_svar_list (append saved_svar_list (list (list n val))))
;сбор несуществующих системных переменных в списке, чтоб лучше читалось в верхнем регистре
(setq errstr (strcat errstr "\n" (strcase n)))
)
);foreach
;далее вывод предупреждений и сообщениий для разработчика программы
;на всякий случай, вдруг неправильно набрали имя переменной в списке.
;в итоговой версии определение errstr и вывод сообщения можно задокументировать.
(if (/= errstr "")
(progn
(alert (strcat errstr "\n\n*ERROR* Not found system variable to save." ));вывод в окно предупреждений Acad
(princ (strcat "\n" errstr ". *ERROR* Not found system variable to save.";вывод в текстовое окно Acad
));princ
)
)
;функция возвращает список имен системных переменных и их значения:
; saved_svar_list = (("SYSVAR_NAME_1" value_1) ("SYSVAR_NAME_2" value_2).....("SYSVAR_NAME_n" value_n))
; или nil если список системных переменных пустой
saved_svar_list
) ;end of **** ABC_SAVE_SVAR ***
;
;----------------------------------------------------------------------------
;Функция возвращения предварительно сохраненных значений системных переменных
; (вызывается при окончании работы программ или в функции обработки ошибок)
;----------------------------------------------------------------------------
(defun ABC_RESTORE_SVAR (saved_svar_list / i list-i)
;параметр функции:
;saved_svar_list = '(("SYSVAR_NAME_1" value_1) ("SYSVAR_NAME_2" value_2).....("SYSVAR_NAME_n" value_n))
;который возвращается функцией ABC_SAVE_SVAR, пример: (("CMDECHO" 1) ("BLIPMODE" 0) ("FILLETRAD" 7.0))
;В программе не рекомендуется изменять список saved_svar_list, выдаваемый функцией ABC_SAVE_SVAR!!
;Данные не проверяются на корректность, поскольку значения системных переменных выдаются Acad!
(foreach n saved_svar_list
(setvar (car n) (cadr n))
);foreach
(prin1);тихий выход (никаких параметров не возвращается).
);end of **** ABC_RESTORE_SVAR ***
;
;----------------------------------------------------------------------------
; Функция для занесения имени программы и текущей даты в файл ABC_LOGPROG.LOG
; (проверка частоты использования программ).
; и возврата строки с именем программы и дат в 2-х форматах через заданный разделитель
;----------------------------------------------------------------------------
(defun ABC_LOGPROG (filename delim / fpath str df date0 date)
; fn [string] - имя программы (файла), например: "ABC_PRGNAME"
; abc_logprog_dir [string] глобальная переменная, сохраняющаяся пока чертеж не закрыт,
; полный путь к файлу ABC_LOGPROG.LOG
; ABC_LOGPROG.LOG - размещается там же где и ABC_FUNCTION.LSP или ABC_FUNCTION.FAS.
; delim [string] разделитель между датой и именем программы. "\t"=табуляция
(if (not (and abc_logprog_dir (= (type abc_logprog_dir) 'STR)));если переменная не назначена или
; кто-то поменял тип переменной, определяем ее снова
(progn
;находим первый из файлов
(if (or (setq fpath (findfile "ABC_FUNCTION.FAS")) (setq fpath (findfile "ABC_FUNCTION.LSP")))
; добавляем к пути имя файла
(setq abc_logprog_dir (strcat (vl-filename-directory fpath) "\\ABC_LOGPROG.LOG"))
(princ "\nFile ABC_FUNCTION.FAS(LSP) not found."); сообщение при неудаче поисков
)
)
)
; отсекаем целое от числа с датой и временем, возвращаемое системной переменной CDATE и получаем "YYYYMMDD"
(setq date0 (rtos (getvar "CDATE") 2 0))
(setq date (strcat (substr date0 7 2) "."; и формируем строку в формате "DD.MM.YYYY"
(substr date0 5 2) "."
(substr date0 1 4)
))
; формируем строку в формате: "ABC_PRGNAME\t20030211\t11.02.2003",
; при просмотре в файле это будет выглядеть примерно так: ABC_PRGNAME 20030211 11.02.2003
(setq str (strcat filename delim date0 delim date))
; задаем дескриптор файла на добавление в конец файла, если путь и имя файла LOG найдены
(if abc_logprog_dir
(progn
(setq df (open abc_logprog_dir "a"));возврашается дескриптор открытого файла
; если файл успешно открыт, то пишем в конец его строку, означающую, что такая то
;программа вызывалась на выполнение
(if df
(write-line str df)
)
(close df) ; закрытие файла
)
)
str; возврат строки из имени программы двух дат в формате: "ABC_PRGNAME\t20030211\t11.02.2003"
);end of ********** ABC_LOGPROG ************
;--------------------------------------------------------------------------------------
; флаг загрузки пользовательских функций (глобальная переменная для всех программ ABC)
;--------------------------------------------------------------------------------------
(setq abc_function_flag Т)
|
|
СПДС. ФАЙЛ ОБЩИХ ФУНКЦИЙ (файл LSP).
