Главная СПДС СПДС. ФАЙЛ ОБЩИХ ФУНКЦИЙ (файл LSP).

;* (наименование и назначение программы)
;* (версия 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 Т)
    

  при полном или частичном использовании материалов сайта ссылка на источник обязательна ©2002-2012