[LISP函数]：Create a windows shortcut

LUCAS

2. 
   
3. ;;Create a windows shortcut
   
4. ;;MODIFY BY LUCAS (龙龙仔)
   
5. ;;FIL = file name must have extension .lnk
   
6. ;;CDIR = shortcut存于目录(目录不存在会出错)
   
7. ;;TARGET = 执行档案
   
8. ;;LST = DESCRIPTION
   
9. ;;WDIR = WORKINGDIRECTORY
   
10. ;;TAG = to overwrite it     T OR NIL
    
11. ;;(F:WINDOWS_SHORTCUT  "CDCHECK.LNK" "C:\\LSP" "C:\\Cdcheck\\CDCheck.exe" '("CDCHECK") "C:\\LSP" T)  
    
12. (defun F:WINDOWS_SHORTCUT
    
13.        (FIL CDIR TARGET LST WDIR TAG / WSH LNK RET COMMENT)
    
14.   (setq FIL (strcat CDIR "\" FIL))
    
15.   (if (or (and (findfile FIL) TAG) (not (findfile FIL))) ;or
    
16.     (progn (setq WSH (vlax-create-object "Wscript.Shell")
    
17.                  LNK (vlax-invoke-method WSH 'CREATESHORTCUT FIL)
    
18.            )                                ;setq
    
19.            (if (not (setq COMMENT (car LST)))
    
20.              (setq COMMENT "")
    
21.            )
    
22.            (if (and (F:VLERR 'vlax-put-property
    
23.                              (list WSH 'CURRENTDIRECTORY CDIR)
    
24.                              NIL
    
25.                     )
    
26.                     (F:VLERR 'vlax-put-property
    
27.                              (list LNK 'TARGETPATH TARGET)
    
28.                              NIL
    
29.                     )
    
30.                     (F:VLERR 'vlax-put-property
    
31.                              (list LNK 'DESCRIPTION COMMENT)
    
32.                              NIL
    
33.                     )
    
34.                     (F:VLERR 'vlax-put-property
    
35.                              (list LNK 'WORKINGDIRECTORY WDIR)
    
36.                              NIL
    
37.                     )
    
38. 
    
39.                     (F:VLERR 'vlax-invoke-method (list LNK 'SAVE) NIL)
    
40.                )                        ;and
    
41.              (progn (mapcar 'vlax-release-object (list WSH LNK))
    
42.                     (setq RET t)
    
43.              )                                ;progn
    
44.            )                                ;if
    
45.     )                                        ;progn
    
46.   )                                        ;if
    
47.   RET
    
48. )
    
49. ;;return the target path of a windows shortcut file (.lnk)
    
50. ;;(F:GET_WINDOWS_SHORTCUT_PROPERTIES "cdcheck.lnk")
    
51. (defun F:GET_WINDOWS_SHORTCUT_PROPERTIES (FIL / WSH LNK PTH COM)
    
52.   (if (setq FIL (findfile FIL))
    
53.     (progn (setq WSH (vlax-create-object "Wscript.Shell")
    
54.                  LNK (vlax-invoke-method WSH 'CREATESHORTCUT FIL)
    
55.                  PTH (vlax-get-property LNK 'TARGETPATH)
    
56.                  COM (vlax-get-property LNK 'DESCRIPTION)
    
57.            )                                ;setq
    
58.            (mapcar 'vlax-release-object (list WSH LNK))
    
59.     )
    
60.   )
    
61.   (if PTH
    
62.     (list PTH COM)
    
63.     NIL
    
64.   )
    
65. )
    
66. 
    
67. ;;simplified error catching routine for vl-catch*
    
68. ;;usage (setq en (f:vlerr 'vla-get-Area (list en) nil))
    
69. ;;tag = true for debugging: princes error message
    
70. (defun F:VLERR (FUN LST TAG / RET)
    
71.   (if (vl-catch-all-error-p
    
72.         (setq RET (vl-catch-all-apply FUN LST))
    
73.       )
    
74.     (if        TAG
    
75.       (progn (princ (vl-catch-all-error-message RET)) NIL)
    
76.       NIL
    
77.     )
    
78.     (if        (not RET)
    
79.       (setq RET t)
    
80.       RET
    
81.     )
    
82.   )
    
83. )
    

<br /> ;;Create a windows shortcut<br /> ;;MODIFY BY LUCAS (龙龙仔)<br /> ;;FIL = file name must have extension .lnk<br /> ;;CDIR = shortcut存于目录(目录不存在会出错)<br /> ;;TARGET = 执行档案<br /> ;;LST = DESCRIPTION<br /> ;;WDIR = WORKINGDIRECTORY<br /> ;;TAG = to overwrite it     T OR NIL<br /> ;;(F:WINDOWS_SHORTCUT  "CDCHECK.LNK" "C:\\LSP" "C:\\Cdcheck\\CDCheck.exe" '("CDCHECK") "C:\\LSP" T)  <br /> (defun F:WINDOWS_SHORTCUT<br />        (FIL CDIR TARGET LST WDIR TAG / WSH LNK RET COMMENT)<br />   (setq FIL (strcat CDIR "\" FIL))<br />   (if (or (and (findfile FIL) TAG) (not (findfile FIL))) ;or<br />     (progn (setq WSH (vlax-create-object "Wscript.Shell")<br />                  LNK (vlax-invoke-method WSH 'CREATESHORTCUT FIL)<br />            )                                ;setq<br />            (if (not (setq COMMENT (car LST)))<br />              (setq COMMENT "")<br />            )<br />            (if (and (F:VLERR 'vlax-put-property<br />                              (list WSH 'CURRENTDIRECTORY CDIR)<br />                              NIL<br />                     )<br />                     (F:VLERR 'vlax-put-property<br />                              (list LNK 'TARGETPATH TARGET)<br />                              NIL<br />                     )<br />                     (F:VLERR 'vlax-put-property<br />                              (list LNK 'DESCRIPTION COMMENT)<br />                              NIL<br />                     )<br />                     (F:VLERR 'vlax-put-property<br />                              (list LNK 'WORKINGDIRECTORY WDIR)<br />                              NIL<br />                     )<br /> <br />                     (F:VLERR 'vlax-invoke-method (list LNK 'SAVE) NIL)<br />                )                        ;and<br />              (progn (mapcar 'vlax-release-object (list WSH LNK))<br />                     (setq RET t)<br />              )                                ;progn<br />            )                                ;if<br />     )                                        ;progn<br />   )                                        ;if<br />   RET<br /> )<br /> ;;return the target path of a windows shortcut file (.lnk)<br /> ;;(F:GET_WINDOWS_SHORTCUT_PROPERTIES "cdcheck.lnk")<br /> (defun F:GET_WINDOWS_SHORTCUT_PROPERTIES (FIL / WSH LNK PTH COM)<br />   (if (setq FIL (findfile FIL))<br />     (progn (setq WSH (vlax-create-object "Wscript.Shell")<br />                  LNK (vlax-invoke-method WSH 'CREATESHORTCUT FIL)<br />                  PTH (vlax-get-property LNK 'TARGETPATH)<br />                  COM (vlax-get-property LNK 'DESCRIPTION)<br />            )                                ;setq<br />            (mapcar 'vlax-release-object (list WSH LNK))<br />     )<br />   )<br />   (if PTH<br />     (list PTH COM)<br />     NIL<br />   )<br /> )<br /> <br /> ;;simplified error catching routine for vl-catch*<br /> ;;usage (setq en (f:vlerr 'vla-get-Area (list en) nil))<br /> ;;tag = true for debugging: princes error message<br /> (defun F:VLERR (FUN LST TAG / RET)<br />   (if (vl-catch-all-error-p<br />         (setq RET (vl-catch-all-apply FUN LST))<br />       )<br />     (if        TAG<br />       (progn (princ (vl-catch-all-error-message RET)) NIL)<br />       NIL<br />     )<br />     (if        (not RET)<br />       (setq RET t)<br />       RET<br />     )<br />   )<br /> )<br />