[LISP]Create a windows shortcut

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