726613 发表于 2013-5-18 19:55 http://bbs.mjtd.com/static/image/common/back.gif
请问朋友，我还是解决不了，请帮我再详细点，谢谢
;;; 双击Setup.dwg时,会Autocad其所在文件夹内的acad.lsp,故本文件命为acad.lsp,并文件Setup.dwg放在一起
;;; 第一步 检测自定命令是否能执行,否则将Setup.dwg所在文件夹内的所有对象全部拷贝到支持文件夹内
;;;第二步,增加<支持文件搜索路径>
;;;第三步,增加菜单
;;;第四点,在启动组加入
(defun s::startup (/ FROM SUPPORTLIST TO)
(vl-load-com)
;;1创建目录
;;用法: (vldos-mkdir DirectoryToCreate)
;;参数: 目录的全路径名. 此函数会自动创建参数中所有不存在的目录.
;;说明: 可创建多层目录.
;;返回值:[成功]创建目录的全路径名;[失败]: 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)
;;参数1: 路径字符串
;;说明: 此函数转换字符 "/" 为 "\\".
;;返回值:[成功]: 转换后的字符串;[失败]: None
(Defun vldos-formatpath (string)
(while (vl-string-search "/" string) (setq string (vl-string-subst "\\" "/" string)))
(while (vl-string-search "\\\\" string)
(setq string (vl-string-subst "\\" "\\\\" string))
)
(setq string (strcase string))
string
)
;;3复制文件或目录
;;用法: (vldos-copy SourceFile/Directory TargetFile/Directory)
;;参数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会自动关闭
自贡黄明儒 发表于 2013-5-19 07:54 static/image/common/back.gif
这个好像是程序打包的引导程序，由于本人水平有限，很难读懂。请赐教，另附上菜单文件等
将yxm.vlx文件添加到启动组 这样也可以，但后面的不行
;自动添加搜索路径（cabinsummer 2012-4-15）
;(setq sp (getenv "ACAD"))
;(setq path '(
;"E:\\00\\CAD外挂\\燕秀工具箱"
;"E:\\00\\CAD外挂"
;))
;;;用加载本程序自动增加
;;;第一步,添加支持文件搜索路径：将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)
;;参数: 目录的全路径名. 此函数会自动创建参数中所有不存在的目录.
;;说明: 可创建多层目录.
;;返回值:[成功]创建目录的全路径名;[失败]: 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)
;;参数1: 路径字符串
;;说明: 此函数转换字符 "/" 为 "\\".
;;返回值:[成功]: 转换后的字符串;[失败]: None
(Defun vldos-formatpath (string)
(while (vl-string-search "/" string) (setq string (vl-string-subst "\\" "/"
string)))
(while (vl-string-search "\\\\" string)
(setq string (vl-string-subst "\\" "\\\\" string))
)
(setq string (strcase string))
string
)
;;3复制文件或目录
;;用法: (vldos-copy SourceFile/Directory TargetFile/Directory)
;;参数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")
)
以上应如何修改才能，用加载的办法来实现呢？请高手指点
顶下，留个记号，下次好找 解决了吗？ (vla-put-QNewTemplateFile
(vla-get-Files(vla-get-Preferences(vlax-get-acad-object)))
"c:\\xzh\\xzh.dwt"
)
页:
1
[2]