Outlook 없이 메일을 발송하기 (CDO.Message)

Outlook 이 설치되지 않은 경우나, Outlook을 사용하지 않고

직접 메일 서버를 통해서 메일을 발송해야 하는 경우에 사용할 수 있습니다.

 

함수로 구현하며,  수신주소, 메일제목, 메일본문, 첨부파일 4가지 인수를 받도록 합니다.

Function SendMailwithCDO(vReceipt As Variant, _
                         sTitle As String, _
                         Optional sBody As Variant = "", _
                         Optional vAttachments As Variant = "")

 

메일 서버에서 발송하기 위해서는 메일서버 및 계정 정보가 필요합니다.

    Dim sName As String   '발송인 이름
    Dim sEmail As String  '발송 메일 주소/계정
    Dim sPass As String   '계정 암호
    Dim sSMTP As String   '메일 발송 서버(SMTP)
    Dim sPort As String   '메일 발송 포트
    Dim bSSL As Boolean   '보안 SSL/TSL 설정 여부
    
    '// 다양한 방법으로 아래 정보를 채우며 됩니다.
    sName = "UserName"
    sEmail = "UserEmail"
    sPass = "UserPass"
    sSMTP = "SMTPServer"
    sPort = "SMTPPort"
    bSSL = True
    
    If sName = "" Or sEmail = "" Or sPass = "" Or sSMTP = "" Or sPort = "" Then
        SendMailwithCDO = "ERROR:SMTP설정이 완료되지 않아서 진행할 수 없습니다.": Exit Function
    End If

 

메일 발송에는 Windows에서 제공하는 CDO를 사용합니다.

CDO.Configuration에  계정 및 서버 정보를 입력하고, CDO를 이용하여 메일을 발송합니다.

    On Error Resume Next
    Dim oCDO As Object:     Set oCDO = CreateObject("CDO.Message")
    If oCDO Is Nothing Then SendMailwithCDO = "ERROR:CDO를 사용할 수 없습니다.": Exit Function
    Dim oConfig As Object:  Set oConfig = CreateObject("CDO.Configuration")
    Dim Flds As Variant
    On Error GoTo 0
    
    oConfig.Load -1    
    Set Flds = oConfig.Fields
    With Flds   '// 서버 및 계정 정보를 입력합니다.
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = sSMTP
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sEmail
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sPass
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = bSSL
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CLng(sPort)
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Update
    End With
    
    With oCDO
        Set .Configuration = oConfig
        '// 수신이에 대한 처리
        .From = """" & sName & """ <" & sEmail & ">"
        .Subject = sTitle
        .TextBody = sBody
        '// 첨부파일에 대한 처리
        .Send 
    End With

 

수신인에 대해서는 단일 주소인지 주소를 가진 배열인지 확인해서 처리합니다.

        If TypeName(vReceipt) = "Ragne" Or isArray(vReceipt) Then
            i = 0
            For Each vItem In vReceipt
                If vItem <> "" And InStr(1, vItem, "@") = 0 Then SendMailwithCDO = "ERROR:수신인 지정이 잘못되었습니다.": Exit Function
                i = i + 1
                If i = 1 Then .To = Replace(vItem, ",", ";")
                If i = 2 Then .CC = Replace(vItem, ",", ";")
                If i = 3 Then .BCC = Replace(vItem, ",", ";")
            Next
        ElseIf TypeName(vReceipt) = "String" Then
            .To = Replace(vReceipt, ",", ";")
        Else
            SendMailwithCDO = "ERROR:수신인 지정이 잘못되었습니다.": Exit Function
        End If

 

첨부파일도 하나인지 여러 첨부의 배열인지 확인하여 처리합니다.

        If TypeName(vAttachments) = "Ragne" Or isArray(vAttachments) Then
            For Each vItem In vAttachments
                If Dir(vItem) = "" Then SendMailwithCDO = "ERROR:첨부파일에 오류가 있습니다.": Exit Function
                .AddAttachment vItem
            Next
        ElseIf TypeName(vAttachments) = "String" Then
            If vAttachments <> "" Then
                If Dir(vAttachments) <> "" Then .AddAttachment vAttachments
            End If
        Else
            SendMailwithCDO = "ERROR:첨부파일에 오류가 있습니다.": Exit Function
        End If

 

에러코드를 추가하여 전체를 정리하면 아래와 같습니다.

Function SendMailwithCDO(vReceipt As Variant, sTitle As String, Optional sBody As Variant = "", Optional vAttachments As Variant = "")
'// Windows CDO를 이용하여 메일을 발송합니다.
    On Error Resume Next
    Dim oCDO As Object:     Set oCDO = CreateObject("CDO.Message")
    If oCDO Is Nothing Then SendMailwithCDO = "ERROR:CDO를 사용할 수 없습니다.": Exit Function
    Dim oConfig As Object:  Set oConfig = CreateObject("CDO.Configuration")
    Dim Flds As Variant
    On Error GoTo 0
    
    Dim vItem As Variant, i As Long
    Dim sName As String, sEmail As String, sPass As String, sSMTP As String, sPort As String, bSSL As Boolean
    
    sName = "UserName"
    sEmail = "UserEmail"
    sPass = "UserPass"
    sSMTP = "SMTPServer"
    sPort = "SMTPPort"
    bSSL = True
        
    If sName = "" Or sEmail = "" Or sPass = "" Or sSMTP = "" Or sPort = "" Then
        SendMailwithCDO = "ERROR:SMTP설정이 완료되지 않아서 진행할 수 없습니다.": Exit Function
    End If
    
    oConfig.Load -1    ' CDO Source Defaults
    Set Flds = oConfig.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = sSMTP
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sEmail
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sPass
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = bSSL
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CLng(sPort)
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Update
    End With
    
    With oCDO
        Set .Configuration = oConfig
        '// 수신인 반영
        If TypeName(vReceipt) = "Ragne" Or isArray(vReceipt) Then
            i = 0
            For Each vItem In vReceipt
                If vItem <> "" And InStr(1, vItem, "@") = 0 Then SendMailwithCDO = "ERROR:수신인 지정이 잘못되었습니다.": Exit Function
                i = i + 1
                If i = 1 Then .To = Replace(vItem, ",", ";")
                If i = 2 Then .CC = Replace(vItem, ",", ";")
                If i = 3 Then .BCC = Replace(vItem, ",", ";")
            Next
        ElseIf TypeName(vReceipt) = "String" Then
            .To = Replace(vReceipt, ",", ";")
        Else
            SendMailwithCDO = "ERROR:수신인 지정이 잘못되었습니다.": Exit Function
        End If
        
        .From = """" & sName & """ <" & sEmail & ">"
        .Subject = sTitle
        .TextBody = sBody
        
        '// 첨부파일 추가
        If TypeName(vAttachments) = "Ragne" Or isArray(vAttachments) Then
            For Each vItem In vAttachments
                If Dir(vItem) = "" Then SendMailwithCDO = "ERROR:첨부파일에 오류가 있습니다.": Exit Function
                .AddAttachment vItem
            Next
        ElseIf TypeName(vAttachments) = "String" Then
            If vAttachments <> "" Then
                If Dir(vAttachments) <> "" Then .AddAttachment vAttachments
            End If
        Else
            SendMailwithCDO = "ERROR:첨부파일에 오류가 있습니다.": Exit Function
        End If
        
        On Error Resume Next
        .Send
        If Err.Number <> 0 Then SendMailwithCDO = "ERROR:Code=" & Err.Number & ",Description=" & Err.description: Exit Function
        On Error GoTo 0
    End With
    
    SendMailwithCDO = True
    Set oCDO = Nothing: Set oConfig = Nothing

End Function

 

현재 EGTools에서는 메일머지 기능에 이 코드를 적용하여 사용하고 있습니다.