构建一个 ACADDOC.lsp，以便在启动时加载驻留在特定环境中的程序目录

nkmjg · 发表于 2024-2-21 15:52:56

;;-----------------=={ ACADDOC.lsp Creator }==----------------;;
;; ;;
;; Creates, or appends to, an ACADDOC.lsp file containing ;;
;; a series of load statements for all program files ;;
;; (lsp/vlx/fas) found in a selected directory. ;;
;;------------------------------------------------------------;;
;;------------------------------------------------------------;;
;; Version 1.1 - 25-05-2011 ;;
;;------------------------------------------------------------;;
(defun c:acaddoc ( / f p d l )
(if
(and
(or (setq f (findfile "ACADDOC.lsp"))
(and (setq p (LM:GetSavePath)) (setq f (strcat p "\\ACADDOC.lsp")))
)
(setq d (LM:DirectoryDialog "\nSelect Program File Directory" nil 512))
(setq l
(apply 'append
(mapcar '(lambda ( typ ) (LM:GetAllFiles d nil typ)) '("*.vlx" "*.fas" "*.lsp"))
)
)
(setq f (open f "a"))
)
(progn
(foreach x l
(write-line
(strcat "(load "
(vl-prin1-to-string x) " "--> Failed to Load: " (vl-filename-base x) "")"
)
f
)
)
(close f)
(princ (strcat "\n<<-- Written " (itoa (length l)) " Files to Load in ACADDOC.lsp -->>"))
)
(princ "\n*Cancel*")
)
(princ)
)
;;-------------------=={ Directory Dialog }==-----------------;;
;; ;;
;; Displays a dialog prompting the user to select a folder ;;
;;------------------------------------------------------------;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; msg - message to display at top of dialog ;;
;; dir - root directory (or nil) ;;
;; flag - bit coded flag specifying dialog display settings ;;
;;------------------------------------------------------------;;
;; Returns: Selected folder filepath, else nil ;;
;;------------------------------------------------------------;;
(defun LM:DirectoryDialog ( msg dir flag / Shell Fold Self Path )
(vl-catch-all-apply
(function
(lambda ( / ac HWND )
(if
(setq Shell (vla-getInterfaceObject (setq ac (vlax-get-acad-object)) "Shell.Application")
HWND (vl-catch-all-apply 'vla-get-HWND (list ac))
Fold (vlax-invoke-method Shell 'BrowseForFolder (if (vl-catch-all-error-p HWND) 0 HWND) msg flag dir)
)
(setq Self (vlax-get-property Fold 'Self)
Path (vlax-get-property Self 'Path)
Path (vl-string-right-trim "\" (vl-string-translate "/" "\" Path))
)
)
)
)
)
(if Self (vlax-release-object Self))
(if Fold (vlax-release-object Fold))
(if Shell (vlax-release-object Shell))
Path
)
;;--------------------=={ Get All Files }==-------------------;;
;; ;;
;; Retrieves all files or those of a specified filetype that ;;
;; reside in a directory (and, optionally, subdirectories) ;;
;;------------------------------------------------------------;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; Dir - Directory to search ;;
;; Subs - Boolean, if T, subdirectories are included ;;
;; Filetype - (optional) Filter for filetype (DOS pattern) ;;
;;------------------------------------------------------------;;
;; Returns: List of filenames, else nil if none are found ;;
;;------------------------------------------------------------;;
(defun LM:GetAllFiles ( Dir Subs Filetype / _GetSubFolders )
(defun _GetSubFolders ( folder )
(apply 'append
(mapcar
(function
(lambda ( f )
(cons (setq f (strcat folder "\" f)) (_GetSubFolders f))
)
)
(vl-remove "." (vl-remove ".." (vl-directory-files folder nil -1)))
)
)
)
(apply 'append
(mapcar
(function
(lambda ( Filepath )
(mapcar
(function
(lambda ( Filename ) (strcat Filepath "\" Filename))
)
(vl-directory-files Filepath Filetype 1)
)
)
)
(cons Dir (if subs (_GetSubFolders Dir)))
)
)
)
;;--------------------=={ Get Save Path }==-------------------;;
;; ;;
;; Returns a save path in an AutoCAD Support Directory ;;
;;------------------------------------------------------------;;
;;------------------------------------------------------------;;
;; Arguments: -None- ;;
;;------------------------------------------------------------;;
;; Returns: Save path in AutoCAD Support Directory, else nil ;;
;;------------------------------------------------------------;;
(defun LM:GetSavePath ( / path )
(if
(vl-file-directory-p
(setq path
(vl-string-right-trim "\"
(vl-string-translate "/" "\"
(substr (getenv "ACAD") 1 (vl-string-position 59 (getenv "ACAD")))
)
)
)
)
path
)
)
(princ) (vl-load-com) (princ)

复制代码

		自动登录	找回密码
密码			立即注册

构建一个 ACADDOC.lsp，以便在启动时加载驻留在特定环境中的程序 目录

构建一个 ACADDOC.lsp，以便在启动时加载驻留在特定环境中的程序目录