通过Outlook发送电子邮件-一种开发人员的方法

最新推荐文章于 2023-08-23 00:17:25 发布

cxygs5788

最新推荐文章于 2023-08-23 00:17:25 发布

阅读量1k

点赞数

文章标签：数据库

使用MS Access管理数据时，使用Access的自动化功能生成电子邮件并将其发送给客户通常会很有帮助。如果您恰巧要发送访问对象（如MS Access生成的报告），则可以使用内置的

.SendObject方法-但是很多时候，我们只是想（或需要）根据您在数据库中所做的工作来生成相关的对应关系。

下面，我将描述我用于通过MS Outlook发送电子邮件的方法。由于这是我们在工作中使用的电子邮件应用程序，并且对于我们许多人来说是标准的桌面应用程序，因此这是一个不错的起点。如果您使用其他电子邮件应用程序（而不是Web电子邮件服务），则可能有一些方法可以修改本文的代码以适应本文的要求，但是我将重点放在MS Outlook作为电子邮件应用程序上。

首先，可以向您的所有表单添加生成电子邮件的代码行，根据需要添加附件，然后正确格式化所有内容。但是，如果这样做，我们每次需要发送电子邮件时都会发现自己在“重新发明轮子”。从开发人员的角度来看，这是浪费比特和字节。一种“更好”的方法可能是在可全局访问的功能中标准化电子邮件发送过程，该功能可以为您完成所有工作。然后，您要做的就是调用该Funciton，并向其发送必要的参数。

这是我们的方法：

首先，在单独的独立VBA模块中，创建您的电子邮件功能：

Option Compare Database
Option Explicit 
Public Function SendAnEMail(olSendTo As String, _
                            olSubject As String, _
                            olEMailBody As String, _
                            olDisplay As Boolean, _
                   Optional olCCLine As String, _
                   Optional olBCCLine As String, _
                   Optional olOnBehalfOf As String, _
                   Optional olAtchs As String, _
                   Optional SendAsHTML As Boolean) As Boolean
On Error GoTo EH
    Dim olApp       As Outlook.Application
    Dim olMail      As Outlook.MailItem
    Dim strArray()  As String
    Dim intAtch     As Integer 
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(olMailItem)
    With olMail
        .To = olSendTo
        .Subject = olSubject 
        If SendAsHTML Then
            .BodyFormat = olFormatHTML
            .HTMLBody = olEMailBody
        Else
            .Body = olEMailBody
        End If 
        .CC = olCCLine
        .BCC = olBCCLine
        .SentOnBehalfOfName = olOnBehalfOf
        strArray = Split(olAtchs, "%Atch") 
        For intAtch = 0 To UBound(strArray)
            If FileExists(strArray(intAtch)) Then _
                .Attachments.Add strArray(intAtch)
        Next intAtch 
        If olDisplay Then
            .Display
        Else
            .Send
        End If 
    End With
    Set olMail = Nothing
    Set olApp = Nothing 
    SendAnEMail = True 
    Exit Function
EH:
    MsgBox "There was an error generating the E-Mail!" & vbCrLf & vbCrLf & _
        "Error: " & Err.Number & vbCrLf & _
        "Description: " & Err.Description & vbCrLf & vbCrLf & _
        "Please contact your Database Administrator.", vbCritical, "WARNING!"
    SendAnEMail = False
    Exit Function
End Function

您会注意到它不是很复杂。我们将以与其他任何地方相同的方式来创建电子邮件。但是，现在可以从项目中的任何位置访问此功能，而您需要做的就是调用它以创建电子邮件。注意：您需要将Microsoft Outlook XX.0对象库作为参考之一。

您可能会注意到附件有一个（只有一个）参数。但是，您可以从调用代码中添加多个附件。请记住，您需要使用文本“％Atch”分隔每个附加文件。

您可能还会注意到对另一个名为

FileExists() 。这样可以确保您不尝试附加不存在的文件。我认为这种功能的版本与程序员一样多，但是这是我的版本（我最初是从Allen Browne那里偷来的，props是应得的props）。

Public Function FileExists(ByVal strFile As String, _
                           Optional bFindFolders As Boolean) _
                           As Boolean
'Purpose:   Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if
'                    no path included.
'           bFindFolders: If strFile is a folder, FileExists() returns False
'                         unless this argument is True.
'Note:      Does not look inside subdirectories for the file.
'Author:    Allen Browne. http://allenbrowne.com June, 2006.
    Dim lngAttributes As Long 
    If Not (IsNull(strFile) Or strFile = "") Then
        'Include read-only files, hidden files, system files.
        lngAttributes = (vbReadOnly Or vbHidden Or vbSystem) 
        If bFindFolders Then
            'Include folders as well.
            lngAttributes = (lngAttributes Or vbDirectory)
        Else
            'Strip any trailing slash, so Dir does not look inside the folder.
            Do While Right$(strFile, 1) = "\"
                strFile = Left$(strFile, Len(strFile) - 1)
            Loop
        End If
        'If Dir() returns something, the file exists.
        On Error Resume Next
        FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
    Else
        FileExists = False
    End If 
End Function

如果需要，此功能可以放在同一模块中。

现在，您可以开始“摇滚乐”了！

在您的表单中，如果您想通过单击按钮发送电子邮件，那么您要做的就是：

Private Sub SendMail_Click()
On Error GoTo EH
    Dim strSendTo     As String
    Dim strSubject    As String
    Dim strEMailBody  As String
    Dim strCCLine     As String
    Dim strBCCLine    As String
    Dim strOnBehalfOf As String
    Dim strAtchs      As String 
    strSendTo = "Orders@PizzaGuy.biz"
    strSubject = "I Want a Pizza"
    strEMailBody = "I want a pizza <B>NOW</B>!!!"
    strCCLine = "MyBuddy@email.net"
    strBCCLine = "MyEnemy@email.net"
    strOnBehalfOf = "CEO@BigBusiness.org"
    strAtchs = "C:\File.pdf" & _
               "%Atch" & _
               "C:\Another File.pdf" 
    'Generate and Display the E-Mail
    Call SendAnEMail(olSendTo:=strsendto, _
                     olSubject:=strSubject, _
                     olEMailBody:=strEMailBody, _
                     olDisplay:=True, _
                     olCCLine:=strCCLine, _
                     olBCCLine:=strBCCLine, _
                     olOnBehalfOf:=strOnBehalfOf, _
                     olAtchs:=strAtchs, _
                     SendAsHTML:=True) 
    Exit Sub
EH:
    MsgBox "There was an error sending mail!" & vbCrLf & vbCrLf & _
        "Error: " & Err.Number & vbCrLf & _
        "Description: " & Err.Description & vbCrLf & vbCrLf & _
        "Please contact your Database Administrator.", vbCritical, "WARNING!"
    Exit Sub