构建一个 ACADDOC.lsp，以便在启动时加载驻留在特定环境中的程序 目录
;;-----------------=={ 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. ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;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 ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;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-objectSelf))
(if Fold(vlax-release-objectFold))
(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) ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;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 ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ?2010 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;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)
页:
[1]