(vl-load-com)
(setq *kpblc-acad* (vlax-get-acad-object)
*kpblc-adoc* (vla-get-activedocument (vlax-get-acad-object))
) ;_ end of setq
(defun test (/ main_menu_file path)
(setq path (vl-string-right-trim
"\\"
(_kpblc-dir-create
(strcat (vl-string-right-trim "\\" (getenv "AppData"))
"\\kpblc\\AutoCAD\\"
(_kpblc-acad-version-with-bit-and-loc)
"\\"
(_kpblc-get-profile-name)
) ;_ end of strcat
) ;_ end of _kpblc-dir-create
) ;_ end of vl-string-right-trim
main_menu_file (cond ((vl-directory-files
(vl-filename-directory (vla-get-menufile (vla-get-files (vla-get-preferences *kpblc-acad*))))
(strcat (vl-filename-base (vla-get-menufile (vla-get-files (vla-get-preferences *kpblc-acad*))))
".*"
) ;_ end of strcat
) ;_ end of vl-directory-files
(vl-filename-base (vla-get-menufile (vla-get-files (vla-get-preferences *kpblc-acad*))))
)
((setq main_menu_file
(findfile
(strcat (vl-filename-base (vla-get-menufile (vla-get-files (vla-get-preferences *kpblc-acad*))))
(if (< (_kpblc-acad-version) 18.)
".cui"
".cuix"
) ;_ end of if
) ;_ end of strcat
) ;_ end of findfile
) ;_ end of setq
(_kpblc-cmd-silence (list "_.menu" main_menu_file))
(vl-filename-base (vla-get-menufile (vla-get-files (vla-get-preferences *kpblc-acad*))))
)
) ;_ end of cond
main_menu_file (car
(vl-remove-if-not
(function (lambda (x)
(= (strcase (vl-filename-base (cdr (assoc "menufilename" x)))) (strcase main_menu_file))
) ;_ end of lambda
) ;_ end of function
(mapcar (function (lambda (x)
(mapcar (function (lambda (pr) (cons (strcase pr t) (vlax-get-property x pr))))
'("name" "menufilename")
) ;_ end of mapcar
) ;_ end of lambda
) ;_ end of function
(_kpblc-conv-vla-to-list (vla-get-menugroups *kpblc-acad*))
) ;_ end of mapcar
) ;_ end of vl-remove-if-not
) ;_ end of car
) ;_ end of setq
(if (/= (strcase
(vl-string-right-trim "\\" (vl-filename-directory (cdr (assoc "menufilename" main_menu_file))))
) ;_ end of strcase
(strcase (vl-string-right-trim "\\" path))
) ;_ end of /=
(progn ;; Здесь код упростил, тупо выполняю копирование файла основного меню
(foreach file (vl-directory-files
path
(strcat (vl-filename-base (cdr (assoc "menufilename" main_menu_file))) ".*")
) ;_ end of vl-directory-files
(vl-file-delete (strcat (_kpblc-dir-path-and-splash (_kpblc-get-path-local "menu")) file))
) ;_ end of foreach
(foreach file (vl-remove-if
(function
(lambda (x)
(or (wcmatch (strcase x t) "*.bak.*,*._*") (not (wcmatch (strcase x t) "*.cui*,*.mnl,*.dll")))
) ;_ end of lambda
) ;_ end of function
(vl-directory-files
(vl-filename-directory (cdr (assoc "menufilename" main_menu_file)))
(strcat (vl-filename-base (cdr (assoc "menufilename" main_menu_file))) ".*")
1
) ;_ end of vl-directory-files
) ;_ end of vl-remove-if
(vl-file-copy
(strcat (vl-string-right-trim "\\" (vl-filename-directory (cdr (assoc "menufilename" main_menu_file))))
"\\"
file
) ;_ end of strcat
(strcat path "\\" file)
) ;_ end of vl-file-copy
) ;_ end of foreach
;; И теперь выполняем установку нового файла меню.
;; Вариант 1: выполнение прекращается с фатальной ошибкой
;|
(vla-put-menufile
(vla-get-preferences *kpblc-acad*)
(strcat path "\\" (vl-filename-base (cdr (assoc "menufilename" main_menu_file))))
) ;_ end of vla-put-menufile
|;
;; Вариант 2: выполнение приводит к ошибке ядра (0x000000c5, кажется)
(vl-cmdf "_.menu"
(strcat path
"\\"
(vl-filename-base (cdr (assoc "menufilename" main_menu_file)))
(if (< (atof (getvar "acadver")) 18.)
".cui"
".cuix"
) ;_ end of if
) ;_ end of strcat
) ;_ end of vl-cmdf
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
(defun _kpblc-acad-version-with-bit ()
(strcat (itoa (atoi (vl-string-trim "VISUALP " (strcase (ver)))))
"x"
(if (and (getvar "platform") (wcmatch (strcase (getvar "platform")) "*X64*"))
"64"
"32"
) ;_ end of if
) ;_ end of strcat
) ;_ end of defun
(defun _kpblc-acad-version-with-bit-and-loc ()
(strcat (_kpblc-acad-version-with-bit)
"-"
(vl-registry-read (strcat "HKEY_LOCAL_MACHINE\\" (vlax-product-key)) "LocaleID")
) ;_ end of strcat
) ;_ end of defun
(defun _kpblc-conv-vla-to-list (value / res)
(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)))
)
(t value)
) ;_ end of cond
) ;_ end of defun
(defun _kpblc-conv-ent-to-ename (ent_value / _lst)
(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-conv-ent-to-vla (ent_value / res)
(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-get-profile-name ()
(vl-list->string
(vl-remove-if-not
(function
(lambda (x) (or (<= 48 x 57) (<= 65 x 90) (<= 97 x 122) (= x 32) (<= 224 x 255) (<= 192 x 223)))
) ;_ end of function
(vl-string->list (getvar "cprofile"))
) ;_ end of vl-remove-if
) ;_ end of VL-LIST->STRING
) ;_ end of defun
(defun _kpblc-dir-create (path / tmp)
(cond ((vl-file-directory-p path) path)
((setq tmp (_kpblc-dir-create (vl-filename-directory path)))
(vl-mkdir (strcat tmp
"\\"
(vl-filename-base path)
(cond ((vl-filename-extension path))
(t "")
) ;_ end of cond
) ;_ end of strcat
) ;_ end of vl-mkdir
(if (vl-file-directory-p path)
path
) ;_ end of if
)
) ;_ end of cond
) ;_ end of defun
