asp-classic-unified-framework/core/lib.CDOEmail.asp

<%

' Class: CDOEmail
' Handles email creation and sending via CDO in VBScript
Class CDOEmail_Class
    ' Public properties
    Public From
    Public Subject
    Public Body
    Public IsBodyHTML
    Public SMTPServer
    Public SMTPPort
    Public SMTPUsername
    Public SMTPPassword
    Public SMTPUseSSL

    ' Private members
    Private cfg
    Private msg
    Private dictRecipients
    Private arrAttachments

    ' Initialize default values and objects
    Private Sub Class_Initialize()
        ' Create CDO configuration and message objects
        Set cfg = Server.CreateObject("CDO.Configuration")
        Set msg = Server.CreateObject("CDO.Message")

        ' Default SMTP settings
        SMTPServer = "localhost"
        SMTPPort = 25
        SMTPUsername = ""
        SMTPPassword = ""
        SMTPUseSSL = False

        ' Initialize recipient collections
        Set dictRecipients = Server.CreateObject("Scripting.Dictionary")
        dictRecipients.Add "TO", Array()
        dictRecipients.Add "CC", Array()
        dictRecipients.Add "BCC", Array()

        ' Initialize attachments dynamic array
        ReDim arrAttachments(-1)

        ' Default message settings
        From = ""
        Subject = ""
        Body = ""
        IsBodyHTML = False
    End Sub

    ' Add a recipient by type: "To", "Cc", or "Bcc"
    Public Sub AddRecipient(recipientType, address)
        Dim key, tmp
        key = UCase(recipientType)
        If Not dictRecipients.Exists(key) Then
            Err.Raise vbObjectError + 1000, "CDOEmail", "Invalid recipient type: " & recipientType
        End If
        tmp = dictRecipients(key)
        If UBound(tmp) < LBound(tmp) Then
            ReDim tmp(0)
        Else
            ReDim Preserve tmp(UBound(tmp) + 1)
        End If
        tmp(UBound(tmp)) = address
        dictRecipients(key) = tmp
    End Sub

    ' Add a file attachment
    Public Sub AddAttachment(filePath)
        If UBound(arrAttachments) < LBound(arrAttachments) Then
            ReDim arrAttachments(0)
        Else
            ReDim Preserve arrAttachments(UBound(arrAttachments) + 1)
        End If
        arrAttachments(UBound(arrAttachments)) = filePath
    End Sub

    ' Send the email, returning True on success, False on failure
    Public Function Send()
        ' Configure SMTP settings
        With cfg.Fields
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2                 ' cdoSendUsingPort
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPPort
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = Choice(Len(SMTPUsername) > 0, 1, 0)                                                   ' cdoBasic or cdoAnonymous
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTPUsername
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SMTPPassword
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = SMTPUseSSL
            .Update
        End With

        ' Apply configuration to message
        Set msg.Configuration = cfg

        ' Populate message fields
        msg.From    = From
        msg.Subject = Subject
        If dictRecipients.Exists("TO") And UBound(dictRecipients("TO")) >= LBound(dictRecipients("TO")) Then
            msg.To = Join(dictRecipients("TO"), ";")
        End If
        If dictRecipients.Exists("CC") And UBound(dictRecipients("CC")) >= LBound(dictRecipients("CC")) Then
            msg.CC = Join(dictRecipients("CC"), ";")
        End If
        If dictRecipients.Exists("BCC") And UBound(dictRecipients("BCC")) >= LBound(dictRecipients("BCC")) Then
            msg.BCC = Join(dictRecipients("BCC"), ";")
        End If

        If IsBodyHTML Then
            msg.HTMLBody = Body
        Else
            msg.TextBody = Body
        End If

        ' Add attachments if any
        Dim i
        For i = LBound(arrAttachments) To UBound(arrAttachments)
            msg.AddAttachment arrAttachments(i)
        Next

        ' Send and handle errors
        On Error Resume Next
        msg.Send
            errNum  = Err.Number
            errDesc = Err.Description
        On Error Goto 0
        If Err.Number <> 0 Then
            Response.Write "CDO Error #" & errNum & ": " & errDesc & "<br/>"
            Send = False
            Err.Clear
        Else
            Send = True
        End If
        
    End Function

    ' Clean up objects
    Private Sub Class_Terminate()
        On Error Resume Next
        Set msg = Nothing
        Set cfg = Nothing
        Set dictRecipients = Nothing
        Erase arrAttachments
    End Sub
End Class

dim CDOEmail_Class__Singleton
Function CDOEmail()
    if IsEmpty(CDOEmail_Class__Singleton) then
        set CDOEmail_Class__Singleton = new CDOEmail_Class
    end if
    set CDOEmail = CDOEmail_Class__Singleton
End Function

%>