[分享]：邮件交换程序源码

aidraft

<CODE>
;;----------------------------------------------------------
;; 文件: SendEmail.lsp
;; 用途: 如果你经常需要在公司和家里的邮箱之间交换电邮附件，
;;       本程序能让你的工作轻松一点点
;; 来源: Internet 作者：未知
;; 修改: Alvin Lin 16.07.04
;; 说明: 需要Doslib支持,也可用(getenv "USERNAME")替代(dos_username)
;;       获取recipients时可能有警告,允许即可.
;;-----------------------------------------------------------
(defun c:send  (/              OUTLOOK            MAIL-ITEM          RECIPIANTS
                LOG-FILE      ATTACHMENTS   desAddress          outlookobj)
  (vl-load-com)
  (cond        ((= (strcase (dos_username)) "家里机器用户名")
         (setq *MY-LISP-PATH* "家里工作路径" ;如"F:\\alin\\"
               desAddress     "公司邮箱"
               outlookobj     "Outlook.Application.10" ;家里用Outlook 10
               )
         )
        ((= (strcase (dos_username)) "家里机器用户名")
         (setq *MY-LISP-PATH* "公司工作路径" ;如"H:\\alin\\"
               desAddress     "家里邮箱"
               outlookobj     "Outlook.Application.9" ;公司用Outlook 9
               )
         )
        )
  (if
    (setq outlook (vlax-get-or-create-object outlookobj))
     (progn
       (setq mail-item (vlax-invoke-method outlook 'CreateItem 0))
;;;       (vlax-invoke-method mail-item 'Save)
;;;       (vlax-invoke-method mail-item 'Display)
       (ADD-RECIPIANTS MAIL-ITEM)
       (vlax-put-property mail-item 'Subject "邮件主题") ;如"我的文件"
;;;       (vlax-GET-property mail-item 'Subject)
       (ATTACH-FILE MAIL-ITEM)
       (if (vlax-invoke-method mail-item 'Send)
         (princ "\n邮件已发出."))
       )
     (princ "\n打开Outlook失败...")
     )
  (princ)
  )
;;---------------------------------------------------
(defun ATTACH-FILE  (MAIL-ITEM / ATTACHMENTS FILE cnt)
  (setq cnt 0)
  (while (setq FILE (getfiled "选择附件" *MY-LISP-PATH* "*" 4))
    (setq ATTACHMENTS (vlax-get-property mail-item 'Attachments))
    (vlax-invoke-method attachments 'Add FILE 1 1)
    (setq cnt (1+ cnt))
    (PRINC (strcat "\n附件"
                   (itoa cnt)
                   ": "
                   (vl-filename-base FILE)
                   (vl-filename-extension FILE)))
    )
  )
;;---------------------------------------------------
(defun ADD-RECIPIANTS  (MAIL-ITEM / RECIPIANTS)
  (setq recipiants (vlax-get-property mail-item 'Recipients))
  (vlax-invoke-method
    recipiants
    'Add
    desAddress
    )
  (princ (strcat "\n收件人: " desAddress))
  )
;
;
(princ "\nType \"Send\" to SEND EMAIL...")
(princ)
</CODE>