(vl-load-com)
(defun c:light-point (/ _kpblc-conv-vla-to-list _kpblc-get-ent-name
_kpblc-property-get _kpblc-conv-ent-to-vla _kpblc-conv-ent-to-ename
_kpblc-list-add-or-subst loc:dcl-create loc:dcl-callback
loc:dcl-execute selset adoc dist
dynprop res step name
)
(defun _kpblc-conv-vla-to-list (value / res)
;|
* Преобразовывает vlax-variant или vlax-safearray в список.
|;
(cond
((listp value)
(mapcar (function _kpblc-conv-vla-to-list) value)
)
((= (type value) 'variant)
(_kpblc-conv-vla-to-list (vlax-variant-value value))
)
((= (type value) 'safearray)
(if (>= (vlax-safearray-get-u-bound value 1) 0)
(_kpblc-conv-vla-to-list (vlax-safearray->list value))
) ;_ end of if
)
((and (member (type value) (list 'ename 'str 'vla-object))
(= (type (_kpblc-conv-ent-to-vla value)) 'vla-object)
(vlax-property-available-p (_kpblc-conv-ent-to-vla value) 'count)
) ;_ end of and
(vlax-for sub (_kpblc-conv-ent-to-vla value)
(setq res (cons sub res))
) ;_ end of vlax-for
)
(t value)
) ;_ end of cond
) ;_ end of defun
(defun _kpblc-get-ent-name (ent /)
;|
* Получение свойства name указанного примитива
* Параметры вызова:
ent указатель на обрабатываемый примитив
допускаются значения
ename
vla-object
string (хендл объекта текущего файла)
|;
(cond ((= (type ent) 'str) ent)
((_kpblc-property-get ent 'effectivename))
((_kpblc-property-get ent 'name))
) ;_ end of cond
) ;_ end of defun
(defun _kpblc-property-get (obj property / res)
;|
* Получение значения свойства объекта
|;
(vl-catch-all-apply
(function
(lambda ()
(if (and obj
(vlax-property-available-p
(setq obj (_kpblc-conv-ent-to-vla obj))
property
) ;_ end of vlax-property-available-p
) ;_ end of and
(setq res (vlax-get-property obj property))
) ;_ end of if
) ;_ end of lambda
) ;_ end of function
) ;_ end of vl-catch-all-apply
res
) ;_ end of defun
(defun _kpblc-conv-ent-to-vla (ent_value / res)
;|
* Функция преобразования полученного значения в vla-указатель.
* Параметры вызова:
* ent_value значение, которое надо преобразовать в указатель. Может
* быть именем примитива, vla-указателем или просто
* списком.
* Если не принадлежит ни одному из указанных типов,
* возвращается nil
* Примеры вызова:
(_kpblc-conv-ent-to-vla (entlast))
(_kpblc-conv-ent-to-vla (vlax-ename->vla-object (entlast)))
|;
(cond
((= (type ent_value) 'vla-object) ent_value)
((= (type ent_value) 'ename) (vlax-ename->vla-object ent_value))
((setq res (_kpblc-conv-ent-to-ename ent_value))
(vlax-ename->vla-object res)
)
) ;_ end of cond
) ;_ end of defun
(defun _kpblc-conv-ent-to-ename (ent_value / _lst)
;|
* Функция преобразования полученного значения в ename
* Параметры вызова:
* ent_value значение, которое надо преобразовать в примитив. Может
* быть именем примитива, vla-указателем или просто
* списком.
* Если не принадлежит ни одному из указанных типов,
* возвращается nil
* Примеры вызова:
(_kpblc-conv-ent-to-ename (entlast))
(_kpblc-conv-ent-to-ename (vlax-ename->vla-object (entlast)))
|;
(cond
((= (type ent_value) 'vla-object)
(vlax-vla-object->ename ent_value)
)
((= (type ent_value) 'ename) ent_value)
((and (= (type ent_value) 'str) (handent ent_value) (entget (handent ent_value)))
(handent ent_value)
)
((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "style" ent_value))
(tblobjname "style" ent_value)
)
((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "dimstyle" ent_value))
(tblobjname "dimstyle" ent_value)
)
((and (= (type ent_value) 'str) (handent ent_value) (tblobjname "block" ent_value))
(tblobjname "block" ent_value)
)
((and (= (type ent_value) 'list) (cdr (assoc -1 ent_value))) (cdr (assoc -1 ent_value)))
(t nil)
) ;_ end of cond
) ;_ end of defun
(defun _kpblc-list-add-or-subst (lst key value)
;|
* Производит замену или дополнение элемента списка новым
* Параметры вызова:
lst обрабатываемый список
key ключ
value устанавливаемое значение
|;
(if (not value)
(vl-remove-if (function (lambda (x) (= (car x) key))) lst)
(if (cdr (assoc key lst))
(subst (cons key value) (assoc key lst) lst)
(cons (cons key value)
(vl-remove-if
(function
(lambda (x)
(= (car x) key)
) ;_ end of lambda
) ;_ end of function
lst
) ;_ end of vl-remove-if
) ;_ end of cons
) ;_ end of if
) ;_ end of if
) ;_ end of defun
(defun loc:dcl-create (/ file handle)
(setq file (strcat (vl-string-right-trim "\\" (getenv "TEMP")) "\\dlg.dcl")
handle (open file "w")
) ;_ end of setq
(foreach item '("dlg:dialog{label=\"ADN-CIS.ORG\";width=\"60\";"
" :column{label=\"Угол поворота\";"
" :edit_box{key=\"rot_cornice\";label=\"На карнизах\";}"
" :edit_box{key=\"rot_space\";label=\"В дверных проемах\";}"
" }"
" :toggle{key=\"use_block\";label=\"Использовать выбранный блок\";}"
" :toggle{key=\"fill\";label=\"Заполнять проем\";}"
" :popup_list{key=\"lst_light_block\";label=\"Имя блока светильника\";}"
; " :row{children_fixed_width=true;"
; " :text{key=\"txt_layer\";label=\"Имя слоя определяющего блока\";}"
; " :popup_list{key=\"lst_layers\";width=\"35\";}"
; " }"
" ok_cancel;"
" }"
)
(write-line item handle)
) ;_ end of foreach
(close handle)
file
) ;_ end of defun
(defun loc:dcl-callback (key value ref)
(set ref (_kpblc-list-add-or-subst (eval ref) key value))
) ;_ end of defun
(defun loc:dcl-execute (/ dcl_file dcl_id dcl_lst dcl_res)
(setq dcl_id (load_dialog (loc:dcl-create)))
(new_dialog "dlg" dcl_id "(loc:dcl-callback $key $value 'dcl_lst)")
(start_list "lst_layers" 3)
(mapcar
(function add_list)
(cdr
(assoc "layers"
(setq dcl_lst (_kpblc-list-add-or-subst
dcl_lst
"layers"
((lambda (/ _res)
(vlax-for item (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
(if (not (wcmatch (vla-get-name item) "*|*"))
(setq _res (cons (vla-get-name item) _res))
) ;_ end of if
) ;_ end of vlax-for
(vl-sort _res '<)
) ;_ end of lambda
)
) ;_ end of _kpblc-list-add-or-subst
) ;_ end of setq
) ;_ end of assoc
) ;_ end of cdr
) ;_ end of mapcar
(end_list)
(start_list "lst_light_block" 3)
(mapcar
(function add_list)
(mapcar
(function car)
(cdr
(assoc "blocks"
(setq dcl_lst (_kpblc-list-add-or-subst
dcl_lst
"blocks"
(vl-remove nil
(mapcar
(function
(lambda (x / tmp)
(if (tblobjname "block" (setq tmp (strcat "L(" (itoa (car x)) "mm)")))
(cons tmp (cdr x))
) ;_ end of if
) ;_ end of lambda
) ;_ end of function
'((300 . 3.1)
(600 . 6.1)
(900 . 9.1)
(1000 . 11.)
(1200 . 13.)
)
) ;_ end of mapcar
) ;_ end of vl-remove
) ;_ end of _kpblc-list-add-or-subst
) ;_ end of setq
) ;_ end of assoc
) ;_ end of cdr
) ;_ end of mapcar
) ;_ end of mapcar
(end_list)
(foreach item (list '("rot_cornice" . "0")
'("rot_space" . "0")
'("use_block" . "1")
'("fill" . "1")
'("lst_light_block" . "0")
(cons "lst_layers"
((lambda (/ item)
(itoa (cond
((setq item (car (vl-remove-if-not
(function
(lambda (x)
(= (strcase x) "_АХП_ВСПОМОГАТЕЛЬНЫЙ_СЛОЙ_НЕ_ПЕЧАТЬ")
) ;_ end of lambda
) ;_ end of function
(cdr (assoc "layers" dcl_lst))
) ;_ end of vl-remove-if-not
) ;_ end of car
) ;_ end of setq
(- (length (cdr (assoc "layers" dcl_lst)))
(length (member item (cdr (assoc "layers" dcl_lst))))
) ;_ end of -
)
(t 0)
) ;_ end of cond
) ;_ end of itoa
) ;_ end of lambda
)
) ;_ end of cons
) ;_ end of list
(set_tile (car item) (cdr item))
(loc:dcl-callback (car item) (cdr item) 'dcl_lst)
) ;_ end of foreach
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)")
(setq dcl_res (start_dialog))
(unload_dialog dcl_id)
(if (= dcl_res 1)
dcl_lst
) ;_ end of if
) ;_ end of defun
(if (and (setq lst (loc:dcl-execute))
(setq selset (ssget "_X"
(list '(0 . "INSERT")
(cons 8 (nth (atoi (cdr (assoc "lst_layers" lst))) (cdr (assoc "layers" lst))))
) ;_ end of list
) ;_ end of ssget
) ;_ end of setq
(setq selset ((lambda (/ tab item)
(repeat (setq tab nil
item (sslength selset)
) ;_ end setq
(setq tab (cons (ssname selset (setq item (1- item))) tab))
) ;_ end of repeat
) ;_ end of lambda
)
) ;_ end of setq
) ;_ end of and
(progn
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(foreach blk selset
(setq dynprop (vlax-variant-value
(_kpblc-property-get
(car (vl-remove-if-not
(function
(lambda (x)
(= (strcase (_kpblc-property-get x 'propertyname))
"РАССТОЯНИЕ1"
) ;_ end of =
) ;_ end of lambda
) ;_ end of function
(_kpblc-conv-vla-to-list (vla-getdynamicblockproperties (vlax-ename->vla-object blk)))
) ;_ end of vl-remove-if-not
) ;_ end of car
'value
) ;_ end of _kpblc-property-get
) ;_ end of vlax-variant-value
name (nth (atoi (cdr (assoc "lst_light_block" lst)))
(cdr (assoc "blocks" lst))
) ;_ end of nth
step (if (or (= (cdr (assoc "fill" lst)) "1")
(wcmatch (strcase (_kpblc-get-ent-name blk)) "!КАРНИЗ")
) ;_ end of or
(cdr name)
(/ dynprop 2.)
) ;_ end of if
name (car name)
dist (if (or (= (cdr (assoc "fill" lst)) "1")
(wcmatch (strcase (_kpblc-get-ent-name blk)) "!КАРНИЗ")
) ;_ end of or
(/ (+ (- dynprop (* step (fix (/ dynprop step)))) step) 2.)
(/ dynprop 2.)
) ;_ end of if
) ;_ end of setq
(while (< dist dynprop)
(setq res (cons (vla-insertblock
(vla-get-modelspace adoc)
(vlax-3d-point (polar (cdr (assoc 10 (entget blk)))
(cdr (assoc 50 (entget blk)))
dist
) ;_ end of polar
) ;_ end of vlax-3d-point
name
1.
1.
1.
(cdr (assoc 50 (entget blk)))
) ;_ end of vla-InsertBlock
res
) ;_ end of cons
dist (+ dist step)
) ;_ end of setq
) ;_ end of while
) ;_ end of foreach
(princ (strcat "\nДобавлено блоков " name " : " (rtos (length res) 2 0) " шт."))
(vla-endundomark adoc)
) ;_ end of progn
) ;_ end of if
(princ)
) ;_ end of defun
