Question

有人知道在访问vba中如何使用outlook 2010发送电子邮件，但避免弹出安全性。我尝试使用FnSendMailSafe代码，但在

上出错

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

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

任何想法???

Answer 1

您需要使用Outlook Redemption Objects。我使用它从Access 2007通过Outlook 2010发送电子邮件，所以我知道它的工作原理。这是一些有效的代码。您需要安装Outlook Redemption对象才能在任何计算机上运行。我没有任何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

从Access 2007发送电子邮件至outlook 2010并避免安全问题

1 个答案: