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

nkmjg

1. ;;-----------------=={ ACADDOC.lsp Creator }==----------------;;
2. ;;                                                            ;;
3. ;;  Creates, or appends to, an ACADDOC.lsp file containing    ;;
4. ;;  a series of load statements for all program files         ;;
5. ;;  (lsp/vlx/fas) found in a selected directory.              ;;
6. ;;------------------------------------------------------------;;
7. ;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
8. ;;------------------------------------------------------------;;
9. ;;  Version 1.1    -    25-05-2011                            ;;
10. ;;------------------------------------------------------------;;
12. (defun c:acaddoc ( / f p d l )
13.   (if
14.     (and
15.       (or (setq f (findfile "ACADDOC.lsp"))
16.         (and (setq p (LM:GetSavePath)) (setq f (strcat p "\\ACADDOC.lsp")))
17.       )
18.       (setq d (LM:DirectoryDialog "\nSelect Program File Directory" nil 512))
19.       (setq l
20.         (apply 'append
21.           (mapcar '(lambda ( typ ) (LM:GetAllFiles d nil typ)) '("*.vlx" "*.fas" "*.lsp"))
22.         )
23.       )
24.       (setq f (open f "a"))
25.     )
26.     (progn
27.       (foreach x l
28.         (write-line
29.           (strcat "(load "
30.             (vl-prin1-to-string x) " "--> Failed to Load: " (vl-filename-base x) "")"
31.           )
32.           f
33.         )
34.       )
35.       (close f)
36.       (princ (strcat "\n<<-- Written " (itoa (length l)) " Files to Load in ACADDOC.lsp -->>"))
37.     )
38.     (princ "\n*Cancel*")
39.   )
40.   (princ)
41. )
43. ;;-------------------=={ Directory Dialog }==-----------------;;
44. ;;                                                            ;;
45. ;;  Displays a dialog prompting the user to select a folder   ;;
46. ;;------------------------------------------------------------;;
47. ;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
48. ;;------------------------------------------------------------;;
49. ;;  Arguments:                                                ;;
50. ;;  msg  - message to display at top of dialog                ;;
51. ;;  dir  - root directory (or nil)                            ;;
52. ;;  flag - bit coded flag specifying dialog display settings  ;;
53. ;;------------------------------------------------------------;;
54. ;;  Returns:  Selected folder filepath, else nil              ;;
55. ;;------------------------------------------------------------;;
57. (defun LM:DirectoryDialog ( msg dir flag / Shell Fold Self Path )
58.   (vl-catch-all-apply
59.     (function
60.       (lambda ( / ac HWND )
61.         (if
62.           (setq Shell (vla-getInterfaceObject (setq ac (vlax-get-acad-object)) "Shell.Application")
63.                 HWND  (vl-catch-all-apply 'vla-get-HWND (list ac))
64.                 Fold  (vlax-invoke-method Shell 'BrowseForFolder (if (vl-catch-all-error-p HWND) 0 HWND) msg flag dir)
65.           )
66.           (setq Self (vlax-get-property Fold 'Self)
67.                 Path (vlax-get-property Self 'Path)
68.                 Path (vl-string-right-trim "\" (vl-string-translate "/" "\" Path))
69.           )
70.         )
71.       )
72.     )
73.   )
74.   (if Self  (vlax-release-object  Self))
75.   (if Fold  (vlax-release-object  Fold))
76.   (if Shell (vlax-release-object Shell))
77.   Path
78. )
80. ;;--------------------=={ Get All Files }==-------------------;;
81. ;;                                                            ;;
82. ;;  Retrieves all files or those of a specified filetype that ;;
83. ;;  reside in a directory (and, optionally, subdirectories)   ;;
84. ;;------------------------------------------------------------;;
85. ;;  Author: Lee Mac, Copyright ?2011 - www.lee-mac.com       ;;
86. ;;------------------------------------------------------------;;
87. ;;  Arguments:                                                ;;
88. ;;  Dir      - Directory to search                            ;;
89. ;;  Subs     - Boolean, if T, subdirectories are included     ;;
90. ;;  Filetype - (optional) Filter for filetype (DOS pattern)   ;;
91. ;;------------------------------------------------------------;;
92. ;;  Returns:  List of filenames, else nil if none are found   ;;
93. ;;------------------------------------------------------------;;
95. (defun LM:GetAllFiles ( Dir Subs Filetype / 采用GetSubFolders )
96.   
97.   (defun 采用GetSubFolders ( folder )
98.     (apply 'append
99.       (mapcar
100.         (function
101.           (lambda ( f )
102.             (cons (setq f (strcat folder "\" f)) (采用GetSubFolders f))
103.           )
104.         )
105.         (vl-remove "." (vl-remove ".." (vl-directory-files folder nil -1)))
106.       )
107.     )
108.   )
110.   (apply 'append
111.     (mapcar
112.       (function
113.         (lambda ( Filepath )
114.           (mapcar
115.             (function
116.               (lambda ( Filename ) (strcat Filepath "\" Filename))
117.             )
118.             (vl-directory-files Filepath Filetype 1)
119.           )
120.         )
121.       )
122.       (cons Dir (if subs (采用GetSubFolders Dir)))
123.     )
124.   )
125. )
127. ;;--------------------=={ Get Save Path }==-------------------;;
128. ;;                                                            ;;
129. ;;  Returns a save path in an AutoCAD Support Directory       ;;
130. ;;------------------------------------------------------------;;
131. ;;  Author: Lee Mac, Copyright ?2010 - www.lee-mac.com       ;;
132. ;;------------------------------------------------------------;;
133. ;;  Arguments: -None-                                         ;;
134. ;;------------------------------------------------------------;;
135. ;;  Returns: Save path in AutoCAD Support Directory, else nil ;;
136. ;;------------------------------------------------------------;;
138. (defun LM:GetSavePath ( / path )
139.   (if
140.     (vl-file-directory-p
141.       (setq path
142.         (vl-string-right-trim "\"
143.           (vl-string-translate "/" "\"
144.             (substr (getenv "ACAD") 1 (vl-string-position 59 (getenv "ACAD")))
145.           )
146.         )
147.       )
148.     )
149.     path
150.   )
151. )
153. (princ) (vl-load-com) (princ)

复制代码