文件夹与样板文件加载

自贡黄明儒 · 发表于 2013-5-19 07:54

本帖最后由自贡黄明儒于 2013-5-19 07:57 编辑

726613 发表于 2013-5-18 19:55
请问朋友，我还是解决不了，请帮我再详细点，谢谢

;;; 双击Setup.dwg时,会Autocad其所在文件夹内的acad.lsp,故本文件命为acad.lsp,并文件Setup.dwg放在一起
;;; 第一步检测自定命令是否能执行,否则将Setup.dwg所在文件夹内的所有对象全部拷贝到支持文件夹内
;;;第二步,增加<支持文件搜索路径>
;;;第三步,增加菜单
;;;第四点,在启动组加入
(defun s::startup (/ FROM SUPPORTLIST TO)
(vl-load-com)
;;1 创建目录
;;用法: (vldos-mkdir DirectoryToCreate[STRING])
;;参数: 目录的全路径名. 此函数会自动创建参数中所有不存在的目录.
;;说明: 可创建多层目录.
;;返回值:[成功]创建目录的全路径名;[失败]: NIL
(Defun vldos-MkDir (Folder / FolderX Fil FFF Pos DIR DRV)
(if (null (setq Fil (vlax-get-or-create-object "Scripting.FileSystemObject")))
(setq Folder nil)
(progn (while (vl-string-search "/" Folder)
(setq Folder (vl-string-subst "\\" "/" Folder))
)
(if (wcmatch Folder "*\\")
(setq Folder (substr Folder 1 (1- (strlen Folder))))
)
(setq FolderX Folder)
(while (setq Pos (vl-string-search "\\" Folder))
(setq FFF (cons (substr Folder 1 Pos) FFF)
Folder (substr Folder (+ Pos 2))
)
)
(setq FFF (reverse (cons Folder FFF))
DRV (car FFF)
FFF (cdr FFF)
)
(foreach DIR FFF
(if (null (vl-file-directory-p (setq DRV (strcat DRV "\\" DIR))))
(vlax-invoke-method Fil 'createfolder DRV)
)
)
(vlax-release-object Fil)
(if (setq Folder (vl-file-directory-p FolderX))
(setq Folder (vldos-formatpath FolderX))
)
)
)
Folder
)
;;2 转换路径中字符 "/" 为 "\\" 并返回大写值
;;用法: (vldos-formatpath PathStringToFormat[STRING])
;;参数1: 路径字符串
;;说明: 此函数转换字符 "/" 为 "\\".
;;返回值:[成功]: 转换后的字符串;[失败]: None
(Defun vldos-formatpath (string)
(while (vl-string-search "/" string) (setq string (vl-string-subst "\\" "/" string)))
(while (vl-string-search "[url=]\\\\[/url]" string)
(setq string (vl-string-subst "\\" "[url=]\\\\[/url]" string))
)
(setq string (strcase string))
string
)
;;3 复制文件或目录
;;用法: (vldos-copy SourceFile/Directory[STRING] TargetFile/Directory[STRING])
;;参数1: 源文件或目录
;;参数2: 目标目录. 如果包含 "*\\" or "*/", 此函数将在此路径下创建相同的子目录.
;;说明: 复制文件或目录.
;;返回值:[成功]: 复制的文件或目录字符串;[失败]: NIL
;;例(vldos-copy2 "D:\\HH" "D:\\DD")此法将HH下的内容(包括文件夹),均放在DD下
(Defun vldos-copy2 (From to / rtn)
(cond ((vl-file-directory-p From)
(if (< (strlen to) 3)
(setq to (strcat to "\\"))
(if (not (vl-file-directory-p to))
(vldos-mkdir to)
)
)
(if (setq Rtn (vlax-get-or-create-object "Scripting.FileSystemObject"))
(progn (vlax-invoke-method Rtn 'CopyFolder From to T)
(vlax-release-object Rtn)
(if (vl-file-directory-p to)
(setq Rtn (vldos-formatpath to))
)
)
)
)
((findfile From)
(vl-file-copy From to)
(if (setq rtn (findfile to))
(setq rtn (vldos-formatpath rtn))
)
)
)
rtn
)
;;4 解析字符串为表
(defun strParse (Str Delimiter / SearchStr StringLen return n char)
(setq SearchStr Str)
(setq StringLen (strlen SearchStr))
(setq return '())
(while (> StringLen 0)
(setq n 1)
(setq char (substr SearchStr 1 1))
(while (and (/= char Delimiter) (/= char ""))
(setq n (1+ n))
(setq char (substr SearchStr n 1))
)
(setq return (cons (substr SearchStr 1 (1- n)) return))
(setq SearchStr (substr SearchStr (1+ n) StringLen))
(setq StringLen (strlen SearchStr))
)
(reverse return)
)
;;5 反解析表为字符串
(defun StrUnParse (Lst Delimiter / return)
(setq return "")
(foreach str Lst (setq return (strcat return Delimiter str)))
(substr return 2)
)
;;6 移除支持文件搜索路径
(defun QF_RemoveSupportPath (PathToRemove / supportlist)
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist (vl-remove "" supportlist))
(setq supportlist (vl-remove-if '(lambda (x) (= (strcase x) (strcase PathToRemove)))
supportlist
)
)
(setenv "ACAD" (strUnParse supportlist ";"))
)
;;7 添加支持文件搜索路径
;; 第二个参数如果为真, 插最前，否则插最后
(defun AddSupportPath (PathToAdd isFirst / supportlist)
(QF_RemoveSupportPath PathToAdd)
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist (vl-remove "" supportlist))
(if isFirst
(setq supportlist (cons PathToAdd supportlist))
(setq supportlist (append supportlist (list PathToAdd)))
)
(setenv "ACAD" (strUnParse supportlist ";"))
)
;;8 在启动组加入
;; 示例(addToStartupSuite
;; "D:\\DT\\DTIImain.lsp")
(defun addToStartupSuite (filename / CT DEFAULT N NUMSTARTUP REGPATH REVISION VERSION)
(setq regpath "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD"
revision (vl-registry-read regpath "CurVer")
version (vl-registry-read (setq regpath (strcat regpath "\\" revision)) "CurVer")
default (vl-registry-read (setq regpath (strcat regpath "\\" version "\\Profiles")))
regpath (strcat regpath "\\" default "\\Dialogs\\Appload\\Startup")
ct 1
)
(if (setq numstartup (vl-registry-read regpath "NumStartup"))
(progn
(setq n (1+ (atoi numstartup)))
(while (and (< ct n)
(/= filename (vl-registry-read regpath (strcat (itoa ct) "Startup")))
)
(setq ct (1+ ct))
)
)
(setq n 1)
)
(if (= n ct)
(progn (vl-registry-write regpath (strcat (itoa n) "Startup") filename)
(vl-registry-write regpath "NumStartup" (itoa n))
)
)
)
;;9 主程序
;;9.1第一步拷贝到支持文件目录下.自己定义的DTIImain.lsp已经在支持目录下
(if (not C:HH)
(progn (setq From (getvar "dwgprefix"))
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq to (car (vl-remove "" supportlist)))
(vldos-copy2 From to)
)
)
;;9.2第二步添加支持文件路径
(if (not (findfile "TD75gljs.VLX"))
(progn (AddSupportPath (strcat to "\\td75") nil)
(AddSupportPath (strcat to "\\Fonts") nil)
)
)
;;9.3 第三步，在启动组中添加路径
(addToStartupSuite (findfile "DTIImain.lsp"))
;;9.4 加载自定义菜单
(if (not (menugroup "CXinZhi"))
(command "menuload" "CXinZhi.mnu")
)
;;9.5 自定义局部菜单放在倒数第三位
(defun mccad-placemenu (/ CNT)
(setq CNT 1)
(while (< CNT 24)
(if (menucmd (strcat "P" (itoa CNT) ".1=?"))
(setq CNT (1+ CNT))
(progn (if (> CNT 2)
(setq CNT (- CNT 2))
(setq CNT 2)
)
(menucmd (strcat "p" (itoa CNT) "=+CXinZhi.pop179"))
(setq CNT 25)
)
)
)
)
(mccad-placemenu)
)
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(IF (and (NOT C:HH) (findfile "DTIImain.lsp"))
(LOAD "DTIImain.lsp")
)
;;(command "CLOSE" "Y")在acad.lsp所在文件夹内的.dwg会自动关闭

;;; 双击Setup.dwg时,会Autocad其所在文件夹内的acad.lsp,故本文件命为acad.lsp,并文件Setup.dwg放在一起 
;;; 第一步 检测自定命令是否能执行,否则将Setup.dwg所在文件夹内的所有对象全部拷贝到支持文件夹内 
;;;第二步,增加<支持文件搜索路径> 
;;;第三步,增加菜单 
;;;第四点,在启动组加入 
(defun s::startup (/ FROM SUPPORTLIST TO) 
  (vl-load-com) 
  ;;1  创建目录 
  ;;用法: (vldos-mkdir DirectoryToCreate[STRING]) 
  ;;参数: 目录的全路径名. 此函数会自动创建参数中所有不存在的目录. 
  ;;说明: 可创建多层目录. 
  ;;返回值:[成功]创建目录的全路径名;[失败]: NIL 
  (Defun vldos-MkDir (Folder / FolderX Fil FFF Pos DIR DRV) 
    (if (null (setq Fil (vlax-get-or-create-object "Scripting.FileSystemObject"))) 
      (setq Folder nil) 
      (progn (while (vl-string-search "/" Folder) 
               (setq Folder (vl-string-subst "\\" "/" Folder)) 
             ) 
             (if (wcmatch Folder "*\\") 
               (setq Folder (substr Folder 1 (1- (strlen Folder)))) 
             ) 
             (setq FolderX Folder) 
             (while (setq Pos (vl-string-search "\\" Folder)) 
               (setq FFF    (cons (substr Folder 1 Pos) FFF) 
                     Folder (substr Folder (+ Pos 2)) 
               ) 
             ) 
             (setq FFF (reverse (cons Folder FFF)) 
                   DRV (car FFF) 
                   FFF (cdr FFF) 
             ) 
             (foreach DIR FFF 
               (if (null (vl-file-directory-p (setq DRV (strcat DRV "\\" DIR)))) 
                 (vlax-invoke-method Fil 'createfolder DRV) 
               ) 
             ) 
             (vlax-release-object Fil) 
             (if (setq Folder (vl-file-directory-p FolderX)) 
               (setq Folder (vldos-formatpath FolderX)) 
             ) 
      ) 
    ) 
    Folder 
  ) 
  ;;2  转换路径中字符 "/" 为 "\\" 并返回大写值 
  ;;用法: (vldos-formatpath PathStringToFormat[STRING]) 
  ;;参数1: 路径字符串 
  ;;说明: 此函数转换字符 "/" 为 "\\". 
  ;;返回值:[成功]: 转换后的字符串;[失败]: None 
  (Defun vldos-formatpath (string) 
    (while (vl-string-search "/" string) (setq string (vl-string-subst "\\" "/" string))) 
    (while (vl-string-search "[url=]\\\\[/url]" string) 
      (setq string (vl-string-subst "\\" "[url=]\\\\[/url]" string)) 
    ) 
    (setq string (strcase string)) 
    string 
  ) 
  ;;3  复制文件或目录 
  ;;用法: (vldos-copy SourceFile/Directory[STRING] TargetFile/Directory[STRING]) 
  ;;参数1: 源文件或目录 
  ;;参数2: 目标目录. 如果包含 "*\\" or "*/", 此函数将在此路径下创建相同的子目录. 
  ;;说明:  复制文件或目录. 
  ;;返回值:[成功]: 复制的文件或目录字符串;[失败]: NIL 
  ;;例(vldos-copy2 "D:\\HH" "D:\\DD")此法将HH下的内容(包括文件夹),均放在DD下 
  (Defun vldos-copy2 (From to / rtn) 
    (cond ((vl-file-directory-p From) 
           (if (< (strlen to) 3) 
             (setq to (strcat to "\\")) 
             (if (not (vl-file-directory-p to)) 
               (vldos-mkdir to) 
             ) 
           ) 
           (if (setq Rtn (vlax-get-or-create-object "Scripting.FileSystemObject")) 
             (progn (vlax-invoke-method Rtn 'CopyFolder From to T) 
                    (vlax-release-object Rtn) 
                    (if (vl-file-directory-p to) 
                      (setq Rtn (vldos-formatpath to)) 
                    ) 
             ) 
           ) 
          ) 
          ((findfile From) 
           (vl-file-copy From to) 
           (if (setq rtn (findfile to)) 
             (setq rtn (vldos-formatpath rtn)) 
           ) 
          ) 
    ) 
    rtn 
  ) 
  ;;4  解析字符串为表 
  (defun strParse (Str Delimiter / SearchStr StringLen return n char) 
    (setq SearchStr Str) 
    (setq StringLen (strlen SearchStr)) 
    (setq return '()) 
    (while (> StringLen 0) 
      (setq n 1) 
      (setq char (substr SearchStr 1 1)) 
      (while (and (/= char Delimiter) (/= char "")) 
        (setq n (1+ n)) 
        (setq char (substr SearchStr n 1)) 
      ) 
      (setq return (cons (substr SearchStr 1 (1- n)) return)) 
      (setq SearchStr (substr SearchStr (1+ n) StringLen)) 
      (setq StringLen (strlen SearchStr)) 
    ) 
    (reverse return) 
  ) 
  ;;5 反解析表为字符串 
  (defun StrUnParse (Lst Delimiter / return) 
    (setq return "") 
    (foreach str Lst (setq return (strcat return Delimiter str))) 
    (substr return 2) 
  ) 
  ;;6 移除支持文件搜索路径 
  (defun QF_RemoveSupportPath (PathToRemove / supportlist) 
    (setq supportlist (strparse (getenv "ACAD") ";")) 
    (setq supportlist (vl-remove "" supportlist)) 
    (setq supportlist (vl-remove-if '(lambda (x) (= (strcase x) (strcase PathToRemove))) 
                                    supportlist 
                      ) 
    ) 
    (setenv "ACAD" (strUnParse supportlist ";")) 
  ) 
  ;;7 添加支持文件搜索路径 
  ;; 第二个参数如果为真, 插最前，否则插最后 
  (defun AddSupportPath (PathToAdd isFirst / supportlist) 
    (QF_RemoveSupportPath PathToAdd) 
    (setq supportlist (strparse (getenv "ACAD") ";")) 
    (setq supportlist (vl-remove "" supportlist)) 
    (if isFirst 
      (setq supportlist (cons PathToAdd supportlist)) 
      (setq supportlist (append supportlist (list PathToAdd))) 
    ) 
    (setenv "ACAD" (strUnParse supportlist ";")) 
  ) 
  ;;8 在启动组加入 
  ;; 示例(addToStartupSuite 
  ;; "D:\\DT\\DTIImain.lsp") 
  (defun addToStartupSuite (filename / CT DEFAULT N NUMSTARTUP REGPATH REVISION VERSION) 
    (setq regpath  "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD" 
          revision (vl-registry-read regpath "CurVer") 
          version  (vl-registry-read (setq regpath (strcat regpath "\\" revision)) "CurVer") 
          default  (vl-registry-read (setq regpath (strcat regpath "\\" version "<a href="http://bbs.mjtd.com/file://profiles/" target="_blank">\\Profiles</a>"))) 
          regpath  (strcat regpath "\\" default "<a href="http://bbs.mjtd.com/file://dialogs//Appload//Startup" target="_blank">\\Dialogs\\Appload\\Startup</a>") 
          ct       1 
    ) 
    (if (setq numstartup (vl-registry-read regpath "NumStartup")) 
      (progn 
        (setq n (1+ (atoi numstartup))) 
        (while (and (< ct n) 
                    (/= filename (vl-registry-read regpath (strcat (itoa ct) "Startup"))) 
               ) 
          (setq ct (1+ ct)) 
        ) 
      ) 
      (setq n 1) 
    ) 
    (if (= n ct) 
      (progn (vl-registry-write regpath (strcat (itoa n) "Startup") filename) 
             (vl-registry-write regpath "NumStartup" (itoa n)) 
      ) 
    ) 
  ) 
  ;;9 主程序 
  ;;9.1第一步 拷贝到支持文件目录下.自己定义的DTIImain.lsp已经在支持目录下 
  (if (not C:HH) 
    (progn (setq From (getvar "dwgprefix")) 
           (setq supportlist (strparse (getenv "ACAD") ";")) 
           (setq to (car (vl-remove "" supportlist))) 
           (vldos-copy2 From to) 
    ) 
  ) 
  ;;9.2第二步 添加支持文件路径 
  (if (not (findfile "TD75gljs.VLX")) 
    (progn (AddSupportPath (strcat to "<a href="http://bbs.mjtd.com/file://td75/" target="_blank">\\td75</a>") nil) 
           (AddSupportPath (strcat to "<a href="http://bbs.mjtd.com/file://fonts/" target="_blank">\\Fonts</a>") nil) 
    ) 
  ) 
  ;;9.3 第三步，在启动组中添加路径    
  (addToStartupSuite (findfile "DTIImain.lsp")) 
  ;;9.4  加载自定义菜单   
  (if (not (menugroup "CXinZhi")) 
    (command "menuload" "CXinZhi.mnu") 
  ) 
  ;;9.5  自定义局部菜单放在倒数第三位 
  (defun mccad-placemenu (/ CNT) 
    (setq CNT 1) 
    (while (< CNT 24) 
      (if (menucmd (strcat "P" (itoa CNT) ".1=?")) 
        (setq CNT (1+ CNT)) 
        (progn (if (> CNT 2) 
                 (setq CNT (- CNT 2)) 
                 (setq CNT 2) 
               ) 
               (menucmd (strcat "p" (itoa CNT) "=+CXinZhi.pop179")) 
               (setq CNT 25) 
        ) 
      ) 
    ) 
  ) 
  (mccad-placemenu) 
) 
;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(IF (and (NOT C:HH) (findfile "DTIImain.lsp")) 
  (LOAD "DTIImain.lsp") 
) 
;;(command "CLOSE" "Y")在acad.lsp所在文件夹内的.dwg会自动关闭

726613 · 发表于 2013-5-19 10:23

自贡黄明儒发表于 2013-5-19 07:54

这个好像是程序打包的引导程序，由于本人水平有限，很难读懂。请赐教，另附上菜单文件等

将yxm.vlx文件添加到启动组

669423907 · 发表于 2013-5-19 20:30

这样也可以，但后面的不行

;自动添加搜索路径（cabinsummer 2012-4-15）
;(setq sp (getenv "ACAD"))
;(setq path '(
;"E:\\00\\CAD外挂\\燕秀工具箱"
;"E:\\00\\CAD外挂"
;))

726613 · 发表于 2013-5-20 08:24

;;;用加载本程序自动增加
;;;第一步,添加支持文件搜索路径：将c:xzh、c:xzh\\dwg、c:xzh\\bmp三个文件夹
添加到支持文件搜索路径
;;;第二步,添加快速新建样板文件：将c:xzh\\xzh.dwt文件添加到快速新建样板文件里

;;;第三步,增加菜单：将c:xzh\\xzh.mns菜单文件增加

;;;第四步,将c:xzh\\yxm.vlx添加到启动组里
(defun c:jz (/ FROM SUPPORTLIST TO)
 (vl-load-com)
 ;;1 创建目录
 ;;用法: (vldos-mkdir DirectoryToCreate[STRING])
 ;;参数: 目录的全路径名. 此函数会自动创建参数中所有不存在的目录.
 ;;说明: 可创建多层目录.
 ;;返回值:[成功]创建目录的全路径名;[失败]: NIL
 (Defun vldos-MkDir (Folder / FolderX Fil FFF Pos DIR DRV)
(if (null (setq Fil (vlax-get-or-create-object "Scripting.FileSystemObject")))
 (setq Folder nil)
 (progn (while (vl-string-search "/" Folder)
 (setq Folder (vl-string-subst "\\" "/" Folder))
 )
 (if (wcmatch Folder "*\\")
 (setq Folder (substr Folder 1 (1- (strlen Folder))))
 )
 (setq FolderX Folder)
 (while (setq Pos (vl-string-search "\\" Folder))
 (setq FFF (cons (substr Folder 1 Pos) FFF)
 Folder (substr Folder (+ Pos 2))
 )
 )
 (setq FFF (reverse (cons Folder FFF))
 DRV (car FFF)
 FFF (cdr FFF)
 )
 (foreach DIR FFF
 (if (null (vl-file-directory-p (setq DRV (strcat DRV "\\" DIR))))
 (vlax-invoke-method Fil 'createfolder DRV)
 )
 )
 (vlax-release-object Fil)
 (if (setq Folder (vl-file-directory-p FolderX))
 (setq Folder (vldos-formatpath FolderX))
 )
 )
)
Folder
 )
 ;;2 转换路径中字符 "/" 为 "\\" 并返回大写值
 ;;用法: (vldos-formatpath PathStringToFormat[STRING])
 ;;参数1: 路径字符串
 ;;说明: 此函数转换字符 "/" 为 "\\".
 ;;返回值:[成功]: 转换后的字符串;[失败]: None
 (Defun vldos-formatpath (string)
(while (vl-string-search "/" string) (setq string (vl-string-subst "\\" "/"
string)))
(while (vl-string-search "[url=]\\\\[/url]" string)
 (setq string (vl-string-subst "\\" "[url=]\\\\[/url]" string))
)
(setq string (strcase string))
string
 )
 ;;3 复制文件或目录
 ;;用法: (vldos-copy SourceFile/Directory[STRING] TargetFile/Directory[STRING])
 ;;参数1: 源文件或目录
 ;;参数2: 目标目录. 如果包含 "*\\" or "*/", 此函数将在此路径下创建相同的子目录.
 ;;说明: 复制文件或目录.
 ;;返回值:[成功]: 复制的文件或目录字符串;[失败]: NIL
 ;;例(vldos-copy2 "D:\\HH" "D:\\DD")此法将HH下的内容(包括文件夹),均放在DD下
 (Defun vldos-copy2 (From to / rtn)
(cond ((vl-file-directory-p From)
 (if (< (strlen to) 3)
 (setq to (strcat to "\\"))
 (if (not (vl-file-directory-p to))
 (vldos-mkdir to)
 )
 )
 (if (setq Rtn (vlax-get-or-create-object "Scripting.FileSystemObject"))
 (progn (vlax-invoke-method Rtn 'CopyFolder From to T)
 (vlax-release-object Rtn)
 (if (vl-file-directory-p to)
 (setq Rtn (vldos-formatpath to))
 )
 )
 )
 )
 ((findfile From)
 (vl-file-copy From to)
 (if (setq rtn (findfile to))
 (setq rtn (vldos-formatpath rtn))
 )
 )
)
rtn
 )
 ;;4 解析字符串为表
 (defun strParse (Str Delimiter / SearchStr StringLen return n char)
(setq SearchStr Str)
(setq StringLen (strlen SearchStr))
(setq return '())
(while (> StringLen 0)
 (setq n 1)
 (setq char (substr SearchStr 1 1))
 (while (and (/= char Delimiter) (/= char ""))
 (setq n (1+ n))
 (setq char (substr SearchStr n 1))
 )
 (setq return (cons (substr SearchStr 1 (1- n)) return))
 (setq SearchStr (substr SearchStr (1+ n) StringLen))
 (setq StringLen (strlen SearchStr))
)
(reverse return)
 )
 ;;5 反解析表为字符串
 (defun StrUnParse (Lst Delimiter / return)
(setq return "")
(foreach str Lst (setq return (strcat return Delimiter str)))
(substr return 2)
 )
 ;;6 移除支持文件搜索路径
 (defun QF_RemoveSupportPath (PathToRemove / supportlist)
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist (vl-remove "" supportlist))
(setq supportlist (vl-remove-if '(lambda (x) (= (strcase x) (strcase PathToRemove)))
 supportlist
 )
)
(setenv "ACAD" (strUnParse supportlist ";"))
 )
 ;;7 添加支持文件搜索路径
 ;; 第二个参数如果为真, 插最前，否则插最后
 (defun AddSupportPath (PathToAdd isFirst / supportlist)
(QF_RemoveSupportPath PathToAdd)
(setq supportlist (strparse (getenv "ACAD") ";"))
(setq supportlist (vl-remove "" supportlist))
(if isFirst
 (setq supportlist (cons PathToAdd supportlist))
 (setq supportlist (append supportlist (list PathToAdd)))
)
(setenv "ACAD" (strUnParse supportlist ";"))
 )
 ;;8 在启动组加入
 ;; 示例(addToStartupSuite
 ;; "c:\\xzh\\yxm.vlx")
 (defun addToStartupSuite (filename / CT DEFAULT N NUMSTARTUP REGPATH REVISION VERSION)
(setq regpath "HKEY_CURRENT_USER\\Software\\Autodesk\\AutoCAD"
 revision (vl-registry-read regpath "CurVer")
 version (vl-registry-read (setq regpath (strcat regpath "\\" revision))
"CurVer")
 default (vl-registry-read (setq regpath (strcat regpath "\\" version
"\\Profiles")))
 regpath (strcat regpath "\\" default "\\Dialogs\\Appload\\Startup")
 ct 1
)
(if (setq numstartup (vl-registry-read regpath "NumStartup"))
 (progn
 (setq n (1+ (atoi numstartup)))
 (while (and (< ct n)
 (/= filename (vl-registry-read regpath (strcat (itoa ct)
"Startup")))
 )
 (setq ct (1+ ct))
 )
 )
 (setq n 1)
)
(if (= n ct)
 (progn (vl-registry-write regpath (strcat (itoa n) "Startup") filename)
 (vl-registry-write regpath "NumStartup" (itoa n))
 )
)
 )
 ;;9 主程序
 ;;9.1第一步拷贝到支持文件目录下.
 (if (not C:HH)
(progn (setq From (getvar "dwgprefix"))
 (setq supportlist (strparse (getenv "ACAD") ";"))
 (setq to (car (vl-remove "" supportlist)))
 (vldos-copy2 From to)
)
 )
 ;;9.2第二步添加支持文件路径
 (if (not (findfile "c:xzh\\xzh.dwt"))
(progn (AddSupportPath (strcat to "C:\\xzh") nil)
 (AddSupportPath (strcat to "C:\\xzh\\dwg") nil)
 (AddSupportPath (strcat to "C:\\xzh\\bmp") nil)
)
 )
 ;;9.3 第三步，在启动组中添加路径
 (addToStartupSuite (findfile "yxm.vlx"))
 ;;9.4 加载自定义菜单
 (if (not (menugroup "xzh"))
(command "menuload" "xzh.mns")
 )
 ;;9.5 自定义局部菜单放在倒数第三位
 (defun mccad-placemenu (/ CNT)
(setq CNT 1)
(while (< CNT 24)
 (if (menucmd (strcat "P" (itoa CNT) ".1=?"))
 (setq CNT (1+ CNT))
 (progn (if (> CNT 2)
 (setq CNT (- CNT 2))
 (setq CNT 2)
 )
 (menucmd (strcat "p" (itoa CNT) "=+xzh.pop12"))
 (menucmd (strcat "p" (itoa CNT) "=+xzh.pop13"))
 (menucmd (strcat "p" (itoa CNT) "=+xzh.pop14"))
 (menucmd (strcat "p" (itoa CNT) "=+xzh.pop15"))
 (menucmd (strcat "p" (itoa CNT) "=+xzh.pop16"))
 (setq CNT 25)
 )
 )
)
 )
 (mccad-placemenu)
)
;;
(IF (and (NOT C:HH)
(findfile "yxm.vlx"))
 (LOAD "yxm")
)

以上应如何修改才能，用加载的办法来实现呢？请高手指点

lxy_2080 · 发表于 2016-3-7 01:07

顶下，留个记号，下次好找

xieling888 · 发表于 2018-9-16 17:17

解决了吗？

utopio · 发表于 2022-10-13 19:27

(vla-put-QNewTemplateFile
(vla-get-Files(vla-get-Preferences(vlax-get-acad-object)))
"c:\\xzh\\xzh.dwt"
)

账号		自动登录	找回密码
密码			注册

[已解答] 文件夹与样板文件加载

本帖子中包含更多资源

本帖子中包含更多资源

点评