Программная настройка AutoCAD, как это делается? - Страница 5
| Правила | Регистрация | Пользователи | Сообщения за день |  Справка по форуму | Файлообменник |

Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Программная настройка AutoCAD, как это делается?

Программная настройка AutoCAD, как это делается?

Ответ
Страница 5 из 9 « 1 < 34 5 67 > 9 »
Перейти к новому Перейти к новому  
Поиск в этой теме
Непрочитано 23.01.2009, 16:34 2 |
Программная настройка AutoCAD, как это делается?
Krieger
 
инженер (КМ)
 
Красноярск
Регистрация: 30.10.2004
Сообщений: 3,837
Программная настройка AutoCAD, как это делается?
Этот пост переправлен из-за неактуальности.
В общем в итоге получилось следующее.
Функцию можно использовать для настройки как чужого компьютера так и своего. Для чужого компа профиль не импортируется, т.е. все прочие настройки кроме прописки адресов остаются на месте. Для своего компа логично импортировать таки профиль, что бы сохранить любые адаптированные под себя мелочи.
Если в файле настроек PathFile есть пункт Profile, то будет производится импорт профиля, тогда функция адреса прописывать не будет, т.к. они хранятся в профиле. Если этого пункта нет, то будут прописываться адреса.
Добавил также возможность копирования своего acad.pgp.

Код:
[Выделить все] 
 ;|Kr_AutoSetup - функция для настройки AutoCAD.
FirstPath - начальная часть адреса к файлам настройки када и PathFile
PathFile - файл настроек с пунктами для настройки:
    Profile
    SupportPath
    PrinterConfigPath
    PrinterDescPath
    PrinterStyleSheetPath
    TemplateDwgPath
    SheetSetTemplatePath
    QNewTemplateFile
    PageSetupOverridesTemplateFile
    ToolPalettePath
    AutoSavePath
    ToolPaletteProfile
    MenuFile
    ACADPGP

Функция импортирует профиль если он указан, если нет - прописывает пути соответсвующих настроек. Копирует файлы Profile.aws и acad.pgp, подгружает меню.
Если какого либо пункта нет, он игнорируется. Если указанного пути не существует, он создается.

Пример:
(Kr_AutoSetup "D:" "\\Library\\Parameters\\Menu\\Kr_Paths.txt")
|;

;Kr_FindTextFileNextString - ищет строку по образцу и выдает следующую
(defun Kr_FindTextFileNextString (File String / key line NextString f promt FullProfileAdress FullPGPAdress)
  (setq f (open File "r") key T)
  (while (and key (setq line (read-line f)))
    (if (eq (strcase String) (strcase line))     (setq key nil NextString (read-line f) promt (strcat "\n" String " - found"))
                      (setq promt (strcat "\n" String " - not found"))
    );if
   );while
  (close f)
  (princ promt)
  (if (or (not NextString) (eq NextString "") (wcmatch NextString "* *")) (setq NextString nil))
  NextString
  );defun


(defun Kr_AutoSetup (FirstPath PathFile / files key f subpaths obj ActiveProfile temp_profile)
  (vl-load-com)
  (if (findfile (strcat FirstPath PathFile))
    (progn
  (setq files (vla-get-files (vla-get-preferences (vlax-get-acad-object))))
;проверка наличия профиля
  (if (setq ProfileAdress (Kr_FindTextFileNextString (strcat FirstPath PathFile) "Profile"));есть ли файл профиля в файле настроек
    (if (setq FullProfileAdress (findfile (strcat FirstPath ProfileAdress)))
     (if (not (vl-string-search ".ARG" (strcase FullProfileAdress))) (setq FullProfileAdress nil) (princ "\nфайл с расширением *.arg найден"));if
      (princ "\nФайл " FullProfileAdress " не найден")
    );if
    (setq FullProfileAdress nil)
   );if
(if (not FullProfileAdress);если профиля нет прописываем настройки вручную
  (progn
;поддержка supportpath
  (if (Kr_FindTextFileNextString (strcat FirstPath PathFile) "SupportPath")
    (progn
      (setq f (open (strcat FirstPath PathFile) "r") paths "" subpaths nil key T)
      (while (and key (setq line (read-line f)))
        (if (eq (strcase "SupportPath") (strcase line))
          (progn
                (while (not (eq "" (setq subpaths (read-line f))))
                    (setq paths (strcat paths ";" FirstPath subpaths))
                  (if (not (vl-file-directory-p (strcat FirstPath subpaths))) (vl-mkdir (strcat FirstPath subpaths)))
                );while
                   (setq key nil)
            );progn
          );if
        );while
      (close f)
      (if (not (eq paths "")) (vla-put-supportpath files (strcat (vla-get-supportpath files) paths)) (princ "address SupportPath is not found"))
      );progn
    (princ "\nАдрес SupportPath не найден")
    );if
;стили печати PrinterStyleSheetPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PrinterStyleSheetPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-PrinterStyleSheetPath files paths))
    (princ "\nАдрес PrinterStyleSheetPath не найден"));if
;папка шаблонов TemplateDwgPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "TemplateDwgPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-TemplateDwgPath files paths))
    (princ "\nАдрес TemplateDwgPath не найден"));if
;шаблон для новых файлов QNewTemplateFile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "QNewTemplateFile")))
    (vla-put-QNewTemplateFile files paths) (princ "\nАдрес QNewTemplateFile не найден"));if
;шаблон для новых листов PageSetupOverridesTemplateFile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PageSetupOverridesTemplateFile")))
    (vla-put-PageSetupOverridesTemplateFile files paths) (princ "\naddress PageSetupOverridesTemplateFile не найден"));if
;папка с палитрами ToolPalettePath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "ToolPalettePath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-ToolPalettePath files paths))
    (princ "\nАдрес ToolPalettePath не найден"));if
;папка для файлов автосохранения AutoSavePath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "AutoSavePath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-AutoSavePath files paths))
    (princ "\nАдрес AutoSavePath не найден"));if
;папка для файлов кофигураций принтеров PrinterConfigPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PrinterConfigPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-PrinterConfigPath files paths))
    (princ "\nАдрес PrinterConfigPath не найден"));if
;папка для PMP файлов (настройка границ печати) PrinterDescPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PrinterDescPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-PrinterDescPath files paths))
    (princ "\nАдрес PrinterDescPath не найден"));if
  );progn
);if
  
;профиль палитры ToolPaletteProfile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "ToolPaletteProfile")))
    ;;копируем профиль палитры
    (progn
      ;;создаем временный профиль
    (vla-CopyProfile (setq obj (vla-get-Profiles (vla-get-preferences (vlax-get-acad-object))))
               (setq ActiveProfile (vla-get-ActiveProfile (vla-get-Profiles (vla-get-preferences (vlax-get-acad-object)))))
               (setq temp_profile (strcat "Prof_tmp_" (substr (rtos (getvar "CDATE") 2 8) 10 8))))
    (vla-put-ActiveProfile obj temp_profile)
      ;;импортируем профиль
      (if FullProfileAdress
    (progn
            (vla-ImportProfile obj (vl-filename-base FullProfileAdress)  FullProfileAdress :vlax-true)
        (setq ActiveProfile (vl-filename-base FullProfileAdress))
    );progn
      );if
      ;;удаляем старый профиль палитры
      (vl-file-delete
            (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
            "support\\Profiles\\" (vl-string-trim "<>" ActiveProfile) "\\Profile.aws")
        );vl-file-delete
      ;;копируем профиль палитры
        (if
      (vl-file-copy
            paths
            (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
          "support\\Profiles\\" (vl-string-trim "<>" ActiveProfile) "\\Profile.aws")
        );vl-file-copy
      (princ "\nProfile.aws - найден")
      (princ "\nProfile.aws - не найден")
      )
      ;;папка шаблонов для подшивок SheetSetTemplatePath
      (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "SheetSetTemplatePath")))
      (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths))
      (vl-registry-write (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" ActiveProfile "\\General")
                          "SheetSetTemplatePath" paths));;progn
      (princ "\nАдрес SheetSetTemplatePath не найден"));;if
      ;;возвращаем активный профиль и удаляем временный
      
          (vla-put-ActiveProfile obj ActiveProfile)
          (vla-DeleteProfile obj temp_profile)
        (vla-put-TextEditor files "");Текстовый редактор сбрасываем на встроенный
    );progn
    (princ "\nАдрес ToolPaletteProfile не найден"));if
;загрузка меню MenuFile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "MenuFile")))
    (if (vl-file-size paths)
      (if (menugroup (vl-filename-base paths))
        (progn
          (vla-unload (vla-Item (vla-get-MenuGroups (vlax-get-acad-object)) (vl-filename-base paths)))
          (vla-load (vla-get-MenuGroups (vlax-get-acad-object)) paths :vlax-false)
        );progn
          (vla-load (vla-get-MenuGroups (vlax-get-acad-object)) paths :vlax-false)
        );if
      (princ (strcat "\n" paths " - не найден"))
      );
       (princ "\nАдрес MenuFile не найден"));if
;копирование acad.pgp

  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "ACADPGP")))
    (if (setq FullPGPAdress (findfile paths))
     (if (vl-string-search "ACAD.PGP" (strcase FullPGPAdress))

       (progn
          ;;удаляем старый acad.pgp
          (vl-file-delete
                (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
                "support\\acad.pgp")
            );vl-file-delete
          ;;копируем acad.pgp
            (if
          (vl-file-copy
                FullPGPAdress
                (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
                "support\\acad.pgp")
              );vl-file-copy
          (princ "acad.pgp найден")
              (princ "acad.pgp не найден")
        );if
     );progn
       
       (princ (strcat "\nНеправильный формат файла" FullPGPAdress))
      );if
      (princ "\nФайл " FullPGPAdress " не найден")
    )
    (princ "\nАдрес ACADPGP не найден")
    );if

  (princ "\nНастройка завершена")
  (alert "Настройка завершена.\nДля сохранения настроек рекомендуется перезагрузить AutoCAD")
  );progn
    (princ (strcat "\nФайл настроек " FirstPath PathFile " не найден"));
    );if
  (princ)
);defun
Пример файла настроек для чужих компов:

Код:
[Выделить все] 
SupportPath
\Library\Parameters\Blocks
\Library\Parameters\Font
\Library\Parameters\Icons
\Library\Parameters\Library_Type
\Library\Parameters\LibraryBlock
\Library\Parameters\Lisp
\Library\Parameters\Lisp\PlineModify
\Library\Parameters\Table

PrinterConfigPath
\Library\Parameters\PlotStyles

PrinterDescPath
\Library\Parameters\PlotStyles

PrinterStyleSheetPath
\Library\Parameters\PlotStyles

TemplateDwgPath
\Library\Parameters\Template\

SheetSetTemplatePath
\Library\Parameters\Template\

QNewTemplateFile
\Library\Parameters\Template\AutoCAD_Beginning_Black.dwt

PageSetupOverridesTemplateFile
\Library\Parameters\Template\AutoCAD_Beginning_Black.dwt

ToolPalettePath
\Library\Parameters\Palette\

AutoSavePath
\AutoSaveAutoCAD

ToolPaletteProfile
\Library\Parameters\Menu\Profile.aws

MenuFile
\Library\Parameters\Menu\Krieger.cui
Пример файла настроек для своего компа:

Код:
[Выделить все] 
Profile
\Library\Parameters\Menu\Krieger.arg

AutoSavePath
\AutoSaveAutoCAD

ToolPaletteProfile
\Library\Parameters\Menu\Profile.aws

MenuFile
\Library\Parameters\Menu\Krieger.cui

ACADPGP
__________________
Делай хорошо, плохо само получится.
Последний раз редактировалось Krieger, 02.02.2012 в 14:35. Причина: Что в итоге получилось
Просмотров: 76738
 
Автор темы   Непрочитано 23.09.2009, 09:21
#81
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837

Спасибо. Можно проще - getenv его читает нормально (getenv "SheetSetTemplatePath")
__________________
Делай хорошо, плохо само получится.
Krieger вне форума  
 
Непрочитано 23.09.2009, 09:24
#82
Кулик Алексей aka kpblc
Moderator

LISP, C# (ACAD 200[9,12,13,14])
 
Регистрация: 25.08.2003
С.-Петербург
Сообщений: 40,426

Лично я с getenv последнее время стараюсь связываться поменьше. Запросто способен вернуть каталог с ~ (т.е. обрезанный по принципу 8.3). Вдобавок регистр читаемого имени имеет значение. А в реестре как-то с этим попроще обычно. Правда, Autodesk и здесь не удержался, свинью ухитрился подложить.
__________________
Моя библиотека lisp-функций
---
Обращение ко мне - на "ты".
Все, что сказано - личное мнение.
Кулик Алексей aka kpblc вне форума  
 
Непрочитано 23.09.2009, 12:17
#83
wetr

инженер
 
Регистрация: 09.08.2006
Владивосток
Сообщений: 1,536
<phrase 1= Отправить сообщение для wetr с помощью Skype™

Krieger, все работает! Спасибо. только вот все равно приходиться ручками группу в палитрах создавать и перетаскивать туда палетты
__________________
14 Ибо если вы будете прощать людям согрешения их, то простит и вам Отец ваш Небесный (Мф 6, 14)
wetr вне форума  
 
Автор темы   Непрочитано 23.09.2009, 12:46
#84
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837

Цитата:
Сообщение от wetr Посмотреть сообщение
Krieger, все работает! Спасибо. только вот все равно приходиться ручками группу в палитрах создавать и перетаскивать туда палетты
Странно. У меня автоматом применяется. Для начала нужно настроить ручками так как оно должно быть. А именно, назначить свой адрес для палитры инструментов (Tool Palettes File Locations), который и будем копировать для переноса палитры; импортировать все наужные палетки (они пропишутся в этой папке); назначить группы и настроить отображение палитры; перезагрузить AutoCAD (или поменять профиль на другой); после перезагрузки када перепишится файл Profile.aws - вот его и надо себе скопировать в укромное местечко, которое потом указывается в файле настроек с адресами. Если все сделано правильно, то должно работать.
Я, кстати, переделал всю прогу, чуть позже выложу.

_____________
Добавлено:

Вот обновленная версия. Добавил проверок, пунктов настройки, создание папок.
Код:
[Выделить все] 
;|Kr_AutoSetupNoProfile - функция для настройки AutoCAD без импорта профиля.
FirstPath - начальная часть адреса к файлам настроки када и PathFile
PathFile - файл настроек с пунктами для настройки:
    SupportPath
    PrinterConfigPath
    PrinterDescPath
    PrinterStyleSheetPath
    TemplateDwgPath
    SheetSetTemplatePath
    QNewTemplateFile
    PageSetupOverridesTemplateFile
    ToolPalettePath
    AutoSavePath
    ToolPaletteProfile
    MenuFile

Функция прописывает пути соответсвующих настроек, копирует файл Profile.aws, подгружает меню.
Если какого либо пункта нет, он игнорируется. Если указанного пути не существует, он создается.

Пример:
(Kr_AutoSetupNoProfile "D:" "\\Library\\Parameters\\Kr_Paths.txt")
|;

;Kr_FindTextFileNextString - ищет строку по образцу и выдает следующую
(defun Kr_FindTextFileNextString (File String / key line NextString f promt)
  (setq f (open File "r") key T)
  (while (and key (setq line (read-line f)))
    (if (eq (strcase String) (strcase line))     (setq key nil NextString (read-line f) promt (strcat "\n" String " - found"))
                      (setq promt (strcat "\n" String " - not found"))
    );if
   );while
  (close f)
  (princ promt)
  (if (or (eq NextString "") (wcmatch NextString "* *")) (setq NextString nil))
  NextString
  );defun


(defun Kr_AutoSetupNoProfile (FirstPath PathFile / files key f subpaths obj ActiveProfile temp_profile)
  (vl-load-com)
  (setq files (vla-get-files (vla-get-preferences (vlax-get-acad-object))))
;поддержка supportpath
  (if (Kr_FindTextFileNextString (strcat FirstPath PathFile) "SupportPath")
    (progn
      (setq f (open (strcat FirstPath PathFile) "r") paths "" subpaths nil key T)
      (while (and key (setq line (read-line f)))
        (if (eq (strcase "SupportPath") (strcase line))
          (progn
                (while (not (eq "" (setq subpaths (read-line f))))
                    (setq paths (strcat paths ";" FirstPath subpaths))
                  (if (not (vl-file-directory-p (strcat FirstPath subpaths))) (vl-mkdir (strcat FirstPath subpaths)))
                );while
                   (setq key nil)
            );progn
          );if
        );while
      (close f)
      (if (not (eq paths "")) (vla-put-supportpath files (strcat (vla-get-supportpath files) paths)) (princ "address SupportPath is not found"))
      );progn
    (princ "\naddress SupportPath is not found")
    );if
;стили печати PrinterStyleSheetPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PrinterStyleSheetPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-PrinterStyleSheetPath files paths))
    (princ "\naddress PrinterStyleSheetPath is not found"));if
;папка шаблонов TemplateDwgPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "TemplateDwgPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-TemplateDwgPath files paths))
    (princ "\naddress TemplateDwgPath is not found"));if
;шаблон для новых файлов QNewTemplateFile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "QNewTemplateFile")))
    (vla-put-QNewTemplateFile files paths) (princ "\naddress is not found"));if
;шаблон для новых листов PageSetupOverridesTemplateFile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PageSetupOverridesTemplateFile")))
    (vla-put-PageSetupOverridesTemplateFile files paths) (princ "\naddress PageSetupOverridesTemplateFile is not found"));if
;папка с палитрами ToolPalettePath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "ToolPalettePath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-ToolPalettePath files paths))
    (princ "\naddress ToolPalettePath is not found"));if
;папка для файлов автосохранения AutoSavePath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "AutoSavePath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-AutoSavePath files paths))
    (princ "\naddress AutoSavePath is not found"));if
;папка для файлов кофигураций принтеров PrinterConfigPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PrinterConfigPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-PrinterConfigPath files paths))
    (princ "\naddress PrinterConfigPath is not found"));if
;папка для PMP файлов (настройка границ печати) PrinterDescPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PrinterDescPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-PrinterDescPath files paths))
    (princ "\naddress PrinterDescPath is not found"));if
;профиль палитры ToolPaletteProfile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "ToolPaletteProfile")))
    ;;копируем профиль палитры
    (progn
      ;;создаем временный профиль
    (vla-CopyProfile (setq obj (vla-get-Profiles (vla-get-preferences (vlax-get-acad-object))))
               (setq ActiveProfile (vla-get-ActiveProfile (vla-get-Profiles (vla-get-preferences (vlax-get-acad-object)))))
               (setq temp_profile (strcat "Prof_tmp_" (substr (rtos (getvar "CDATE") 2 8) 10 8))))
    (vla-put-ActiveProfile obj temp_profile)
      ;;удаляем старый профиль палитры
      (vl-file-delete
            (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
            "support\\Profiles\\" ActiveProfile "\\Profile.aws")
        );vl-file-delete
      ;;копируем профиль палитры
        (if
      (vl-file-copy
            paths
            (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
          "support\\Profiles\\" ActiveProfile "\\Profile.aws")
        );vl-file-copy
      (princ "\nProfile.aws - found")
      (princ "\nProfile.aws - not found")
      )
      ;;папка шаблонов для подшивок SheetSetTemplatePath
      (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "SheetSetTemplatePath")))
      (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths))
      (vl-registry-write (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" ActiveProfile "\\General")
                          "SheetSetTemplatePath" paths));;progn
      (princ "\naddress SheetSetTemplatePath is not found"));;if
      ;;возвращаем активный профиль и удаляем временный
          (vla-put-ActiveProfile obj ActiveProfile)
          (vla-DeleteProfile obj temp_profile)
    );progn
    (princ "\naddress ToolPaletteProfile is not found"));if
;загрузка меню MenuFile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "MenuFile")))
    (if (vl-file-size paths)
      (if (menugroup (vl-filename-base paths))
        (progn
          (vla-unload (vla-Item (vla-get-MenuGroups (vlax-get-acad-object)) (vl-filename-base paths)))
          (vla-load (vla-get-MenuGroups (vlax-get-acad-object)) paths :vlax-false)
        );progn
          (vla-load (vla-get-MenuGroups (vlax-get-acad-object)) paths :vlax-false)
        );if
      (princ (strcat "\n" paths " - not found"))
      );
       (princ "\naddress MenuFile is not found"));if
  (princ "\nAdjustment is finishedd")
);defun
Пример PathFile:
Код:
[Выделить все] 
SupportPath
\Library\Parameters\Blocks
\Library\Parameters\Font
\Library\Parameters\Icons
\Library\Parameters\Library_Type
\Library\Parameters\LibraryBlock
\Library\Parameters\Lisp
\Library\Parameters\Lisp\PlineModify
\Library\Parameters\Table

PrinterConfigPath
\Library\Parameters\PlotStyles

PrinterDescPath
\Library\Parameters\PlotStyles

PrinterStyleSheetPath
\Library\Parameters\PlotStyles

TemplateDwgPath
\Library\Parameters\Template\

SheetSetTemplatePath
\Library\Parameters\Template\

QNewTemplateFile
\Library\Parameters\Template\AutoCAD_Beginning_Black.dwt

PageSetupOverridesTemplateFile
\Library\Parameters\Template\AutoCAD_Beginning_Black.dwt

ToolPalettePath
\Library\Parameters\Palette\

AutoSavePath
\AutoSaveAutoCAD

ToolPaletteProfile
\Library\Parameters\Menu\Profile.aws

MenuFile
\Library\Parameters\Menu\Krieger.cui
Специально для wetr в архиве:
Вложения
Тип файла: rar Kr_AutoSetupNoProfile.rar (2.2 Кб, 205 просмотров)
__________________
Делай хорошо, плохо само получится.
Последний раз редактировалось Krieger, 23.09.2009 в 14:07.
Krieger вне форума  
 
Автор темы   Непрочитано 01.10.2009, 11:55
#85
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837

Так, еще кое-что дописал, функция теперь более универсальная. Т.е. теперь её можно использовать для настройки как чужого компьютера так и своего. Для чужого компа профиль не импортируется, т.е. все прочие настройки кроме прописки адресов остаются на месте. Для своего компа логично импортировать таки профиль, что бы сохранить любые адаптированные под себя мелочи.
Если в файле настроек PathFile есть пункт Profile, то будет производится импорт профиля, тогда функция адреса прописывать не будет, т.к. они хранятся в профиле. Если этого пункта нет, то будут прописываться адреса.
Добавил также возможность копирования своего acad.pgp.
Код:
[Выделить все] 
;|Kr_AutoSetup - функция для настройки AutoCAD.
FirstPath - начальная часть адреса к файлам настройки када и PathFile
PathFile - файл настроек с пунктами для настройки:
    Profile
    SupportPath
    PrinterConfigPath
    PrinterDescPath
    PrinterStyleSheetPath
    TemplateDwgPath
    SheetSetTemplatePath
    QNewTemplateFile
    PageSetupOverridesTemplateFile
    ToolPalettePath
    AutoSavePath
    ToolPaletteProfile
    MenuFile
    ACADPGP

Функция импортирует профиль если он указан, если нет - прописывает пути соответсвующих настроек. Копирует файлы Profile.aws и acad.pgp, подгружает меню.
Если какого либо пункта нет, он игнорируется. Если указанного пути не существует, он создается.

Пример:
(Kr_AutoSetup "D:" "\\Library\\Parameters\\Menu\\Kr_Paths.txt")
|;

;Kr_FindTextFileNextString - ищет строку по образцу и выдает следующую
(defun Kr_FindTextFileNextString (File String / key line NextString f promt FullProfileAdress FullPGPAdress)
  (setq f (open File "r") key T)
  (while (and key (setq line (read-line f)))
    (if (eq (strcase String) (strcase line))     (setq key nil NextString (read-line f) promt (strcat "\n" String " - found"))
                      (setq promt (strcat "\n" String " - not found"))
    );if
   );while
  (close f)
  (princ promt)
  (if (or (not NextString) (eq NextString "") (wcmatch NextString "* *")) (setq NextString nil))
  NextString
  );defun


(defun Kr_AutoSetup (FirstPath PathFile / files key f subpaths obj ActiveProfile temp_profile)
  (vl-load-com)
  (if (findfile (strcat FirstPath PathFile))
    (progn
  (setq files (vla-get-files (vla-get-preferences (vlax-get-acad-object))))
;проверка наличия профиля
  (if (setq ProfileAdress (Kr_FindTextFileNextString (strcat FirstPath PathFile) "Profile"));есть ли файл профиля в файле настроек
    (if (setq FullProfileAdress (findfile (strcat FirstPath ProfileAdress)))
     (if (not (vl-string-search ".ARG" (strcase FullProfileAdress))) (setq FullProfileAdress nil) (princ "\nфайл с расширением *.arg найден"));if
      (princ "\nФайл " FullProfileAdress " не найден")
    );if
    (setq FullProfileAdress nil)
   );if
(if (not FullProfileAdress);если профиля нет прописываем настройки вручную
  (progn
;поддержка supportpath
  (if (Kr_FindTextFileNextString (strcat FirstPath PathFile) "SupportPath")
    (progn
      (setq f (open (strcat FirstPath PathFile) "r") paths "" subpaths nil key T)
      (while (and key (setq line (read-line f)))
        (if (eq (strcase "SupportPath") (strcase line))
          (progn
                (while (not (eq "" (setq subpaths (read-line f))))
                    (setq paths (strcat paths ";" FirstPath subpaths))
                  (if (not (vl-file-directory-p (strcat FirstPath subpaths))) (vl-mkdir (strcat FirstPath subpaths)))
                );while
                   (setq key nil)
            );progn
          );if
        );while
      (close f)
      (if (not (eq paths "")) (vla-put-supportpath files (strcat (vla-get-supportpath files) paths)) (princ "address SupportPath is not found"))
      );progn
    (princ "\nАдрес SupportPath не найден")
    );if
;стили печати PrinterStyleSheetPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PrinterStyleSheetPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-PrinterStyleSheetPath files paths))
    (princ "\nАдрес PrinterStyleSheetPath не найден"));if
;папка шаблонов TemplateDwgPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "TemplateDwgPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-TemplateDwgPath files paths))
    (princ "\nАдрес TemplateDwgPath не найден"));if
;шаблон для новых файлов QNewTemplateFile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "QNewTemplateFile")))
    (vla-put-QNewTemplateFile files paths) (princ "\nАдрес QNewTemplateFile не найден"));if
;шаблон для новых листов PageSetupOverridesTemplateFile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PageSetupOverridesTemplateFile")))
    (vla-put-PageSetupOverridesTemplateFile files paths) (princ "\naddress PageSetupOverridesTemplateFile не найден"));if
;папка с палитрами ToolPalettePath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "ToolPalettePath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-ToolPalettePath files paths))
    (princ "\nАдрес ToolPalettePath не найден"));if
;папка для файлов автосохранения AutoSavePath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "AutoSavePath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-AutoSavePath files paths))
    (princ "\nАдрес AutoSavePath не найден"));if
;папка для файлов кофигураций принтеров PrinterConfigPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PrinterConfigPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-PrinterConfigPath files paths))
    (princ "\nАдрес PrinterConfigPath не найден"));if
;папка для PMP файлов (настройка границ печати) PrinterDescPath
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "PrinterDescPath")))
    (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths)) (vla-put-PrinterDescPath files paths))
    (princ "\nАдрес PrinterDescPath не найден"));if
  );progn
);if
  
;профиль палитры ToolPaletteProfile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "ToolPaletteProfile")))
    ;;копируем профиль палитры
    (progn
      ;;создаем временный профиль
    (vla-CopyProfile (setq obj (vla-get-Profiles (vla-get-preferences (vlax-get-acad-object))))
               (setq ActiveProfile (vla-get-ActiveProfile (vla-get-Profiles (vla-get-preferences (vlax-get-acad-object)))))
               (setq temp_profile (strcat "Prof_tmp_" (substr (rtos (getvar "CDATE") 2 8) 10 8))))
    (vla-put-ActiveProfile obj temp_profile)
      ;;импортируем профиль
      (if FullProfileAdress
    (progn
            (vla-ImportProfile obj (vl-filename-base FullProfileAdress)  FullProfileAdress :vlax-true)
        (setq ActiveProfile (vl-filename-base FullProfileAdress))
    );progn
      );if
      ;;удаляем старый профиль палитры
      (vl-file-delete
            (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
            "support\\Profiles\\" (vl-string-trim "<>" ActiveProfile) "\\Profile.aws")
        );vl-file-delete
      ;;копируем профиль палитры
        (if
      (vl-file-copy
            paths
            (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
          "support\\Profiles\\" (vl-string-trim "<>" ActiveProfile) "\\Profile.aws")
        );vl-file-copy
      (princ "\nProfile.aws - найден")
      (princ "\nProfile.aws - не найден")
      )
      ;;папка шаблонов для подшивок SheetSetTemplatePath
      (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "SheetSetTemplatePath")))
      (progn (if (not (vl-file-directory-p paths)) (vl-mkdir paths))
      (vl-registry-write (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" ActiveProfile "\\General")
                          "SheetSetTemplatePath" paths));;progn
      (princ "\nАдрес SheetSetTemplatePath не найден"));;if
      ;;возвращаем активный профиль и удаляем временный
      
          (vla-put-ActiveProfile obj ActiveProfile)
          (vla-DeleteProfile obj temp_profile)
        (vla-put-TextEditor files "");Текстовый редактор сбрасываем на встроенный
    );progn
    (princ "\nАдрес ToolPaletteProfile не найден"));if
;загрузка меню MenuFile
  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "MenuFile")))
    (if (vl-file-size paths)
      (if (menugroup (vl-filename-base paths))
        (progn
          (vla-unload (vla-Item (vla-get-MenuGroups (vlax-get-acad-object)) (vl-filename-base paths)))
          (vla-load (vla-get-MenuGroups (vlax-get-acad-object)) paths :vlax-false)
        );progn
          (vla-load (vla-get-MenuGroups (vlax-get-acad-object)) paths :vlax-false)
        );if
      (princ (strcat "\n" paths " - не найден"))
      );
       (princ "\nАдрес MenuFile не найден"));if
;копирование acad.pgp

  (if (setq paths (strcat FirstPath (Kr_FindTextFileNextString (strcat FirstPath PathFile) "ACADPGP")))
    (if (setq FullPGPAdress (findfile paths))
     (if (vl-string-search "ACAD.PGP" (strcase FullPGPAdress))

       (progn
          ;;удаляем старый acad.pgp
          (vl-file-delete
                (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
                "support\\acad.pgp")
            );vl-file-delete
          ;;копируем acad.pgp
            (if
          (vl-file-copy
                FullPGPAdress
                (strcat (vl-registry-read (strcat "HKEY_CURRENT_USER\\" (vlax-product-key)) "RoamableRootFolder")
                "support\\acad.pgp")
              );vl-file-copy
          (princ "acad.pgp найден")
              (princ "acad.pgp не найден")
        );if
     );progn
       
       (princ (strcat "\nНеправильный формат файла" FullPGPAdress))
      );if
      (princ "\nФайл " FullPGPAdress " не найден")
    )
    (princ "\nАдрес ACADPGP не найден")
    );if

  (princ "\nНастройка завершена")
  (alert "Настройка завершена.\nДля сохранения настроек рекомендуется перезагрузить AutoCAD")
  );progn
    (princ (strcat "\nФайл настроек " FirstPath PathFile " не найден"));
    );if
  (princ)
);defun
Пример файла настроек для чужих компов:
Код:
[Выделить все] 
SupportPath
\Library\Parameters\Blocks
\Library\Parameters\Font
\Library\Parameters\Icons
\Library\Parameters\Library_Type
\Library\Parameters\LibraryBlock
\Library\Parameters\Lisp
\Library\Parameters\Lisp\PlineModify
\Library\Parameters\Table

PrinterConfigPath
\Library\Parameters\PlotStyles

PrinterDescPath
\Library\Parameters\PlotStyles

PrinterStyleSheetPath
\Library\Parameters\PlotStyles

TemplateDwgPath
\Library\Parameters\Template\

SheetSetTemplatePath
\Library\Parameters\Template\

QNewTemplateFile
\Library\Parameters\Template\AutoCAD_Beginning_Black.dwt

PageSetupOverridesTemplateFile
\Library\Parameters\Template\AutoCAD_Beginning_Black.dwt

ToolPalettePath
\Library\Parameters\Palette\

AutoSavePath
\AutoSaveAutoCAD

ToolPaletteProfile
\Library\Parameters\Menu\Profile.aws

MenuFile
\Library\Parameters\Menu\Krieger.cui
Пример файла настроек для своего компа:
Код:
[Выделить все] 
Profile
\Library\Parameters\Menu\Krieger.arg

AutoSavePath
\AutoSaveAutoCAD

ToolPaletteProfile
\Library\Parameters\Menu\Profile.aws

MenuFile
\Library\Parameters\Menu\Krieger.cui

ACADPGP
\Library\Parameters\Menu\acad.pgp
__________________
Делай хорошо, плохо само получится.
Последний раз редактировалось Krieger, 01.10.2009 в 12:01.
Krieger вне форума  
 
Непрочитано 01.10.2009, 11:58
#86
Sleekka

-
 
Регистрация: 24.07.2005
Москва
Сообщений: 1,335

Спасибо Krieger. Весьма пользительно.
Sleekka вне форума  
 
Непрочитано 03.02.2010, 05:24
#87
wetr

инженер
 
Регистрация: 09.08.2006
Владивосток
Сообщений: 1,536
<phrase 1= Отправить сообщение для wetr с помощью Skype™

Krieger, у меня последняя версия не работает.
И предпоследняя (та, что из архива) тоже
Код:
[Выделить все] 
Command: (load "Kr_AutoSetupNoProfile")(Kr_AutoSetupNoProfile "T:" 
"\\КОП\\ПГС\\ACAD 2009 settings\\Paths.txt")

SupportPath - found
address SupportPath is not found
PrinterStyleSheetPath - found; error: bad argument type: stringp nil
Код:
[Выделить все] 
Command: (load "Kr_AutoSetup")(Kr_AutoSetup "T:" "\\КОП\\ПГС\\ACAD 2009 
settings\\Paths.txt")

Profile - not found
SupportPath - found
Адрес SupportPath не найден
PrinterStyleSheetPath - found; error: bad argument type: stringp nil
Код:
[Выделить все] 
SupportPath
\КОП\ПГС\ACAD 2009 settings\Files
\КОП\ПГС\ACAD 2009 settings\ARX
\КОП\ПГС\ACAD 2009 settings\LISP\Icons
\КОП\ПГС\ACAD 2009 settings\VetCAD++
\КОП\ПГС\ACAD 2009 settings\Fonts
\КОП\ПГС\ACAD 2009 settings\LISP
\КОП\ПГС\ACAD 2009 settings\PLTools
\КОП\ПГС\ACAD 2009 settings\LIN


PrinterStyleSheetPath
\КОП\ПГС\ACAD 2009 settings\Plot Styles

TemplateDwgPath
\КОП\ПГС\ACAD 2009 settings\Шаблон

SheetSetTemplatePath
\КОП\ПГС\ACAD 2009 settings\SheetSet

QNewTemplateFile
\КОП\ПГС\ACAD 2009 settings\Шаблон\универсальный.dwt

PageSetupOverridesTemplateFile
\КОП\ПГС\ACAD 2009 settings\Шаблон\универсальный.dwt

ToolPalettePath
\КОП\ПГС\ACAD 2009 settings\ToolPalette

ToolPaletteProfile
\КОП\ПГС\ACAD 2009 settings\Profile 2009\Profile.aws

MenuFile
\КОП\ПГС\ACAD 2009 settings\CUI\myCUI.cui
Что бы это могло быть?
__________________
14 Ибо если вы будете прощать людям согрешения их, то простит и вам Отец ваш Небесный (Мф 6, 14)
wetr вне форума  
 
Автор темы   Непрочитано 18.02.2010, 06:13
#88
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837

> wetr
Корень бед я пока вижу в пробелах. Их нужно убрать. Тут два варианта:
1. В своих адресах у брать пробелы.
2. Или в коде попробовать убрать строчку " (wcmatch NextString "* *") " просто выделить по этим скобкам и удалить.

Использовать последний код.
__________________
Делай хорошо, плохо само получится.
Krieger вне форума  
 
Непрочитано 18.02.2010, 08:06
#89
wetr

инженер
 
Регистрация: 09.08.2006
Владивосток
Сообщений: 1,536
<phrase 1= Отправить сообщение для wetr с помощью Skype™

Цитата:
Сообщение от Krieger Посмотреть сообщение
> wetr
Корень бед я пока вижу в пробелах. Их нужно убрать. Тут два варианта:
1. В своих адресах у брать пробелы.
2. Или в коде попробовать убрать строчку " (wcmatch NextString "* *") " просто выделить по этим скобкам и удалить.

Использовать последний код.
Спасибо. Попробую.
Думаю лучше 1 вариант, а то потом опять где нибудь вылезет
__________________
14 Ибо если вы будете прощать людям согрешения их, то простит и вам Отец ваш Небесный (Мф 6, 14)
wetr вне форума  
 
Непрочитано 09.04.2010, 18:19
#90
shartal


 
Регистрация: 12.08.2009
Сообщений: 464

Господа, а как воспользоваться данным файлом. Загрузить как лисп? Отвечает, что ошибка и аргументов мало.
shartal вне форума  
 
Автор темы   Непрочитано 09.04.2010, 18:41
#91
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837

Использовать последний код в посту №85.
Лисп загрузить и выполнить функцию с необходимыми параметрами. Пример запуска есть в коде
Цитата:
(Kr_AutoSetup "D:" "\\Library\\Parameters\\Menu\\Kr_Paths.txt")
http://dwg.ru/pub/9
__________________
Делай хорошо, плохо само получится.
Krieger вне форума  
 
Непрочитано 15.04.2010, 16:17
#92
shartal


 
Регистрация: 12.08.2009
Сообщений: 464

Спасибо, все отлично. Можно ли добавить загрузку корпоративного (enterprise) файла cui?
shartal вне форума  
 
Автор темы   Непрочитано 15.04.2010, 16:22
#93
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837

А что это за gui такое? Просто еще одно меню?
__________________
Делай хорошо, плохо само получится.
Krieger вне форума  
 
Непрочитано 15.04.2010, 16:59
#94
shartal


 
Регистрация: 12.08.2009
Сообщений: 464

Это меню добавляемое к основному. Основное меню неизменно. Корпоративное может программно изменяться.
shartal вне форума  
 
Автор темы   Непрочитано 15.04.2010, 17:10
#95
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837

Ну есть же пункт в файле настроек:
Код:
[Выделить все] 
MenuFile
\Library\Parameters\Menu\Krieger.cui
Позже добавлю возможность добавления нескольких cui.
Или я дурак, или лыжи не едут...
__________________
Делай хорошо, плохо само получится.
Krieger вне форума  
 
Непрочитано 15.04.2010, 17:37
#96
shartal


 
Регистрация: 12.08.2009
Сообщений: 464

Он заменит основной файл. А надо чтобы его оставит и заменил корпоративный.
shartal вне форума  
 
Автор темы   Непрочитано 15.04.2010, 17:42
#97
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837

Меню не заменяются, а добавляются. Набери в комстроке "menuload" и увидишь что их несколько.
__________________
Делай хорошо, плохо само получится.
Krieger вне форума  
 
Непрочитано 15.04.2010, 17:56
#98
shartal


 
Регистрация: 12.08.2009
Сообщений: 464

Тогда это получаются частичные файлы cui, которые добавляются в основной. В разделе Настройки есть спец. место для корпоративного cui предприятия.
shartal вне форума  
 
Автор темы   Непрочитано 15.04.2010, 18:38
#99
Krieger

инженер (КМ)
 
Регистрация: 30.10.2004
Красноярск
Сообщений: 3,837

Корпоративное меню к какому меню цепляться должно?
__________________
Делай хорошо, плохо само получится.
Krieger вне форума  
 
Непрочитано 16.04.2010, 10:23
#100
shartal


 
Регистрация: 12.08.2009
Сообщений: 464

Оно ни куда не цепляется. В этом его достоинство. У каждого юзера есть свое меню с прицеплянными частичными. Но есть корпоративное, которое он даже изменить сам не может. В путях поддержки, в файлах адаптации для него есть свое место.
shartal вне форума  
Ответ
Страница 5 из 9 « 1 < 34 5 67 > 9 »
Вернуться   Форум DWG.RU > Программное обеспечение > Программирование > Программная настройка AutoCAD, как это делается?



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Рифмоплетство. Kryaker Разное 554 14.11.2023 11:59
запуск программы из AutoCADа kminas Программирование 19 15.06.2012 13:42
Предложение: Готовые функции Apelsinov Библиотека функций 170 27.06.2010 23:51
Новый драйвер для Phantom AutoCAD OLE/ADI Printer. Как? CyberMan AutoCAD 4 26.04.2009 10:19
Электромагнитная пушка T-Yoke Машиностроение 112 06.08.2008 18:48

Обратная связь - Вверх