从 access 2007 发送电子邮件到 Outlook 2010 并避免安全问题

Question

有谁知道在 access vba 中如何使用 Outlook 2010 发送电子邮件，但要避免安全弹出。我尝试使用 FnSendMailSafe 代码，但在

上出现错误

blnSuccessful = objOutlook.FnSendMailSafe(strTo, strCC, strBCC, _
                                                strSubject, strMessageBody, _
                                                strAttachmentPaths)

错误 438 对象不支持此属性或方法

有什么想法吗？？？

Answer 1

您需要使用 Outlook 兑换对象。我用它从 Access 2007 通过 Outlook 2010 发送电子邮件，所以我知道它可以工作。这是一些工作代码。您需要安装 Outlook Redemption Objects 才能在任何机器上工作。我没有将任何 sub 的参数设为可选。如果过程中某处发生错误，您也可以考虑将其更改为一个函数并传回一个 false 布尔值。

Call subHandleSendingEmail("display", "billgates@microsoft.com", "", "", "Subject goes here", "my message body", "")


Private Sub subHandleSendingEmail(sDisplayOrSend As String, _
                                sTo As String, _
                                sCC As String, _
                                sBCC As String, _
                                sSubject As String, _
                                sMsgBody As String, _
                                sAtts As String)



    'sAtts is expected to be a list of files to attach, delimited by "|" (known as a pipe)

    Const olFolderOutbox = 4
    Const olFolderDrafts = 16

    'This section of code will attempt to get an instance of the Outlook object using late binding.
    'If Outlook is closed the code should open Outlook.
    'If Outlook is not installed or the install is corrupted, this section of code should detect that.
    On Error Resume Next

    Dim oOutlookApp As Object
    Set oOutlookApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Err.Clear
        Set oOutlookApp = CreateObject("Outlook.Application")
        If Err.Number <> 0 Then
            MsgBox "Error: " & Err.Number & vbCrLf & vbCrLf & _
                    Err.description & vbCrLf & vbCrLf & _
                    "Apparently you do not have Outlook installed or configured properly."
            Err.Clear
            Set oOutlookApp = Nothing
            Exit Sub
        End If
    End If

    Dim oSession As Object, oMsg As Object, oAttach As Object
    Dim i As Integer, sEntryID As String, sStoreID As String

    On Error Resume Next
    Set oSession = CreateObject("Redemption.RDOSession")

    If Err.Number <> 0 Then
        MsgBox "Please contact your database administrator and give him the following message:" & vbCrLf & vbCrLf & _
            "There was a problem creating the RDOSession. Outlook Redemption Objects must not be installed."
        Err.Clear
        Set oSession = Nothing
        Set oOutlookApp = Nothing
        Exit Sub
    End If

    oSession.Logon
    Set oMsg = oSession.GetDefaultFolder(olFolderDrafts).Items.Add
    sStoreID = oSession.GetDefaultFolder(olFolderDrafts).StoreID

    sEntryID = oMsg.EntryID

    'Multiple email addresses can be passed into the email address fields
    'by passing them into this function, separated by a semicolon

    'If you want to validate the email addresses to make sure they actually have an
    '@ symbol in them and have a domain name that's formatted correctly, you'll
    'need to do it before passing it into this function or do it below.

    oMsg.To = sTo
    oMsg.CC = sCC
    oMsg.Bcc = sBCC

    oMsg.Subject = sSubject

    'This code will put the attachment filenames listed in sAtts into an array
    'and then attach each file as an attachment and embed the jpegs into the body.
    If sAtts <> "" Then
        i = 0
        If InStr(sAtts, "|") = 0 Then sAtts = sAtts & "|" & " "
        'Remove any doubled up delimiters
        sAtts = Replace(sAtts, "||", "|")
        Dim aryAtt() As String
        aryAtt = Split(sAtts, "|")

        Do Until i = (UBound(aryAtt) + 1)
            'Check to see if the filename is blank before attaching it
            If Trim(aryAtt(i)) <> "" Then
                'Check to see if the file actually exists before attaching it
                If Dir(aryAtt(i)) <> "" Then
                    Set oAttach = oMsg.Attachments.Add(aryAtt(i))
                    'If the attachment is a .jpg assume that we want to embed it in the email
                    If right(aryAtt(i), 4) = ".jpg" Then
                        oAttach.Fields("MimeTag") = "image/jpeg"
                        oAttach.Fields(&H3712001E) = "picture" & CStr(i)
                        'I'm assuming we want the pictures below the optional text that's passed into this function
                        sMsgBody = sMsgBody & "<br><br><IMG align=baseline border=0 hspace=0 src=cid:picture" & CStr(i) & "><br>"
                    End If
                End If
            End If
            i = i + 1
        Loop
    End If


    oMsg.HTMLBody = sMsgBody
    oMsg.Save

    sEntryID = oMsg.EntryID

    If LCase(sDisplayOrSend) = "send" Then
        oMsg.send
    End If

    oSession.Logoff
    Set oAttach = Nothing
    Set oMsg = Nothing
    Set oSession = Nothing


    If LCase(sDisplayOrSend) = "display" Then
        Set oMsg = oOutlookApp.GetNamespace("MAPI").GetItemFromID(sEntryID, sStoreID)
        Err.Clear
        On Error Resume Next
        oMsg.Display
        If Err.Number <> 0 Then
            MsgBox "There was a problem displaying the new email because there is a dialog box " & _
                "open in Outlook. Please go to Outlook to resolve this problem, " & _
                "then look for the new email in your Drafts folder."
            Err.Clear
        End If
        Set oMsg = Nothing
    End If

    Set oOutlookApp = Nothing

End Sub