ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 3665|回复: 2

[分享] Outlook发送和接收邮件避免弹出警告的办法

[复制链接]

TA的精华主题

TA的得分主题

发表于 2010-6-4 13:55 | 显示全部楼层 |阅读模式
发送邮件无警告弹出函数:

Public Function FnSendMailSafe(strTo As String, _
                                strCC As String, _
                                strBCC As String, _
                                strSubject As String, _
                                strMessageBody As String, _
                                Optional strAttachments As String) As Boolean

' (c) 2005 Wayne Phillips - Written 07/05/2005
' Last updated 26/03/2008 - Bugfix for empty recipient strings
' http://www.everythingaccess.com
'
' You are free to use this code within your application(s)
' as long as the copyright notice and this message remains intact.

On Error GoTo ErrorHandler:

    Dim MAPISession As Outlook.NameSpace
    Dim MAPIFolder As Outlook.MAPIFolder
    Dim MAPIMailItem As Outlook.MailItem
    Dim oRecipient As Outlook.Recipient

    Dim TempArray() As String
    Dim varArrayItem As Variant
    Dim strEmailAddress As String
    Dim strAttachmentPath As String

    Dim blnSuccessful As Boolean

    'Get the MAPI NameSpace object
    Set MAPISession = Application.Session

    If Not MAPISession Is Nothing Then

      'Logon to the MAPI session
      MAPISession.Logon , , True, False

      'Create a pointer to the Outbox folder
      Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
      If Not MAPIFolder Is Nothing Then

        'Create a new mail item in the "Outbox" folder
        Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
        If Not MAPIMailItem Is Nothing Then

          With MAPIMailItem

            'Create the recipients TO
                TempArray = Split(strTo, ";")
                For Each varArrayItem In TempArray

                    strEmailAddress = Trim(varArrayItem)
                    If Len(strEmailAddress) > 0 Then
                        Set oRecipient = .Recipients.Add(strEmailAddress)
                        oRecipient.Type = olTo
                        Set oRecipient = Nothing
                    End If

                Next varArrayItem

            'Create the recipients CC
                TempArray = Split(strCC, ";")
                For Each varArrayItem In TempArray

                    strEmailAddress = Trim(varArrayItem)
                    If Len(strEmailAddress) > 0 Then
                        Set oRecipient = .Recipients.Add(strEmailAddress)
                        oRecipient.Type = olCC
                        Set oRecipient = Nothing
                    End If

                Next varArrayItem

            'Create the recipients BCC
                TempArray = Split(strBCC, ";")
                For Each varArrayItem In TempArray

                    strEmailAddress = Trim(varArrayItem)
                    If Len(strEmailAddress) > 0 Then
                        Set oRecipient = .Recipients.Add(strEmailAddress)
                        oRecipient.Type = olBCC
                        Set oRecipient = Nothing
                    End If

                Next varArrayItem

            'Set the message SUBJECT
                .Subject = strSubject

            'Set the message BODY (HTML or plain text)
                If StrComp(Left(strMessageBody, 6), "<HTML>", _
                            vbTextCompare) = 0 Then
                    .HTMLBody = strMessageBody
                Else
                    .Body = strMessageBody
                End If

            'Add any specified attachments
'                TempArray = Split(strAttachments, ";")
'                For Each varArrayItem In TempArray
'
'                    strAttachmentPath = Trim(varArrayItem)
'                    If Len(strAttachmentPath) > 0 Then
'                        .Attachments.Add strAttachmentPath
'                    End If
'
'                Next varArrayItem

            .Send 'The message will remain in the outbox if this fails

            Set MAPIMailItem = Nothing

          End With

        End If

        Set MAPIFolder = Nothing

      End If

      MAPISession.Logoff

    End If

    'If we got to here, then we shall assume everything went ok.
    blnSuccessful = True

ExitRoutine:
    Set MAPISession = Nothing
    FnSendMailSafe = blnSuccessful

    Exit Function

ErrorHandler:
    MsgBox "An error has occured in the user defined Outlook VBA function " & _
            "FnSendMailSafe()" & vbCrLf & vbCrLf & _
            "Error Number: " & CStr(Err.Number) & vbCrLf & _
            "Error Description: " & Err.Description, _
                vbApplicationModal + vbCritical
    Resume ExitRoutine

End Function

接收邮件无警告弹出函数:
Public Function GetEmailContent() As Integer
  On Error GoTo ErrorHandler:

    Dim MAPISession As Outlook.NameSpace
    Dim MAPIFolder As Outlook.MAPIFolder
    Dim MAPIMailItem As Outlook.MailItem
    Dim oRecipient As Outlook.Recipient

    Dim TempArray() As String
    Dim varArrayItem As Variant
    Dim strEmailAddress As String
    Dim strAttachmentPath As String

    Dim blnSuccessful As Boolean

    'Get the MAPI NameSpace object
    Set MAPISession = Application.Session

    If Not MAPISession Is Nothing Then

      'Logon to the MAPI session
      MAPISession.Logon , , True, False

      'Create a pointer to the Outbox folder
      Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderInbox)
      If Not MAPIFolder Is Nothing Then

        'Create a new mail item in the "Inbox" folder
        Dim vItem As Object
        Dim strname As String
        If MAPIFolder.UnReadItemCount > 0 Then
        For Each vItem In MAPIFolder.Items
           If vItem.UnRead = True Then
           strname = vItem.Subject
           strname = Replace(strname, "*", "_")
           strname = Replace(strname, "\", "_")
           strname = Replace(strname, "/", "_")
           strname = Replace(strname, "$", "_")
           strname = Replace(strname, "%", "_")
           strname = Replace(strname, "!", "_")
           strname = Replace(strname, "~", "_")
           strname = Replace(strname, "(", "_")
           strname = Replace(strname, ")", "_")
           strname = Replace(strname, "+", "_")
           strname = Replace(strname, ":", "_")
           vItem.SaveAs "D:\" & strname & ".txt", olTXT
           vItem.UnRead = False
           End If
        Next
    End If

        Set MAPIFolder = Nothing

      End If

      MAPISession.Logoff

    End If

    'If we got to here, then we shall assume everything went ok.
    blnSuccessful = True

ExitRoutine:
    Set MAPISession = Nothing
    'FnSendMailSafe = blnSuccessful

    Exit Function

ErrorHandler:
    MsgBox "An error has occured in the user defined Outlook VBA function " & _
            "FnSendMailSafe()" & vbCrLf & vbCrLf & _
            "Error Number: " & CStr(Err.Number) & vbCrLf & _
            "Error Description: " & Err.Description, _
                vbApplicationModal + vbCritical
    Resume ExitRoutine
End Function

如果遇到无法使用Outlook的Macro的情况,请在tools->Macro->Security->设置安全级别为low.

TA的精华主题

TA的得分主题

发表于 2010-6-6 12:30 | 显示全部楼层

〖Excel Home友情提示〗

   

很遗憾通知楼上朋友,您的帖子在24小时之内没有任何回复!

通常情况下,本论坛发布的主题帖会在8小时被回复或处理。您的帖子在24小时之内未被回复,其中的原因可能是

1、问题表述不清、模棱两可,难以理解,帮助者被搞晕了,夺帖而出;
2、没有上传必要的附件,或附件被遗忘在某个角落;
3、发帖提问时,语气带棱角、带挑衅,不幸被列入不受欢迎的帖子;
4、所提问题不成立,或提不合理的要求,乐于助人者使出“走为上”之计;
5、话题较偏、较冷或者发布到了不合适的版块,暂时无人问津,顾影自怜。


为了提高您的问题解决效率,我们推荐您阅读以下文章:
* 如何发表新话题和上传附件:http://club.excelhome.net/thread-45649-1-1.html
* 发帖的技巧:http://club.excelhome.net/thread-176339-1-1.html
* EH技术论坛的最佳学习方法:http://club.excelhome.net/thread-117862-1-1.html

TA的精华主题

TA的得分主题

发表于 2012-12-5 16:58 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 宁侠(理想) 于 2012-12-5 16:58 编辑

楼主,能说明下那部分代码是用来避免弹出警告的吗?多谢!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 16:16 , Processed in 0.042133 second(s), 9 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表