Advertisement
Guest User

CSendMail.cls

a guest
Dec 1st, 2017
134
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1.  
  2. Option Explicit
  3.  
  4. ' authentication modes  
  5. Public Enum enAuthMode
  6.   amAnonymous = 0
  7.   amBasic = 1
  8.   amNTLM = 2
  9. End Enum
  10.  
  11. ' return receipt flags
  12. Public Enum enReceiptFlags
  13.   rfDefault = 0
  14.   rfNever = 1
  15.   rfFailure = 2
  16.   rfSuccess = 4
  17.   rfDelay = 5
  18.   rfAll = 14
  19. End Enum
  20.  
  21. ' HTML body type
  22. Public Enum enHtmlBodyType
  23.   htNone = 0
  24.   htHTML = 1
  25.   htURL = 2
  26.   htFile = 3
  27. End Enum
  28.  
  29. ' signal failure
  30. Public Event Failure(ByVal lNum As Long, ByVal sMsg As String, ByVal sInfo As String)
  31. Public Event Notice(ByVal sMsg As String)
  32.  
  33. ' server configuration
  34. Private msServer    As String
  35. Private mlPort      As Long
  36. Private mlTimeOut   As Long
  37. Private mbUseSSL    As Boolean
  38. Private mnAuthMode  As enAuthMode
  39. Private msUser      As String
  40. Private msPass      As String
  41.  
  42. ' last error data
  43. Private mlErrNum    As Long
  44. Private msErrMsg    As String
  45. Private msErrInfo   As String
  46.  
  47. ' CDO configuration
  48. Private mbReconfig  As Boolean
  49. Private mobjCDOcfg   As Object
  50.  
  51. ' ================================================================
  52. ' CLASS INSTANCE
  53. ' ================================================================
  54.  
  55. ' constructor
  56. Private Sub Class_Initialize()
  57.   mbReconfig = True
  58.   msServer = "localhost"
  59.   mlPort = 0
  60.   mlTimeOut = 30
  61.   mbUseSSL = False
  62.   mnAuthMode = amAnonymous
  63.   msUser = ""
  64.   msPass = ""
  65.   SetError 0, "", ""
  66. End Sub
  67.  
  68. ' destructor
  69. Private Sub Class_Terminate()
  70.   Set mobjCDOcfg = Nothing
  71. End Sub
  72.  
  73. ' ================================================================
  74. ' PUBLIC PROPERTIES
  75. ' ================================================================
  76.  
  77. ' server name or IP
  78. Public Property Let Server(ByVal sServer As String)
  79.   msServer = sServer
  80.   mbReconfig = True
  81. End Property
  82.  
  83. ' port number, 0=autoconfig
  84. Public Property Let Port(ByVal lPort As Long)
  85.   mlPort = lPort
  86.   If (mlPort < 1) Or (mlPort > 65535) Then
  87.     mlPort = 0
  88.   End If
  89.   mbReconfig = True
  90. End Property
  91.  
  92. ' connection timeout
  93. Public Property Let ConnTimeOut(ByVal lTimeOut As Long)
  94.   mlTimeOut = lTimeOut
  95.   mbReconfig = True
  96. End Property
  97.  
  98. ' true to use SSL (not TLS, CDO doesn't support it)
  99. Public Property Let UseSSL(ByVal bYesNo As Boolean)
  100.   mbUseSSL = bYesNo
  101.   mbReconfig = True
  102. End Property
  103.  
  104. ' authentication mode
  105. Public Property Let AuthMode(ByVal nMode As enAuthMode)
  106.   mnAuthMode = nMode
  107.   mbReconfig = True
  108. End Property
  109.  
  110. ' user name
  111. Public Property Let User(ByVal sUser As String)
  112.   msUser = sUser
  113.   mbReconfig = True
  114. End Property
  115.  
  116. ' password
  117. Public Property Let Password(ByVal sPassword As String)
  118.   msPass = sPassword
  119.   mbReconfig = True
  120. End Property
  121.  
  122. ' last error number
  123. Public Property Get ErrNum() As Long
  124.   ErrNum = mlErrNum
  125. End Property
  126.  
  127. ' last error message
  128. Public Property Get ErrMsg() As String
  129.   ErrMsg = msErrMsg
  130. End Property
  131.  
  132. ' last error informations
  133. Public Property Get ErrInfo() As String
  134.   ErrInfo = msErrInfo
  135. End Property
  136.  
  137. ' ================================================================
  138. ' PUBLIC METHODS
  139. ' ================================================================
  140.  
  141. ' send an email message
  142. Public Function SendMail(ByVal sFrom As String, _
  143.                          ByVal sTo As String, _
  144.                          ByVal sCc As String, _
  145.                          ByVal sBCc As String, _
  146.                          ByVal sSubject As String, _
  147.                          ByVal sTextBody As String, _
  148.                          Optional ByVal nReceipt As enReceiptFlags = rfDefault,
  149.                          Optional ByVal nHtmlType = htNone
  150.                          Optional ByVal sHtmlData As String = "", _
  151.                          Optional ByVal colAttach As Collection
  152.                          ) As Boolean
  153.   Dim objMsg As Object
  154.   Dim sConf As String, sFile As String
  155.   Dim vItem As Variant
  156.   Dim bResult As Boolean
  157.  
  158.   ' init
  159.  bResult = False
  160.   SendMail = bResult
  161.   SetError 0, "", ""
  162.  
  163.  
  164.   ' check if the config needs to be initialized
  165.  ' this is done once so that sending multiple
  166.  ' mail messages will be faster, the config is
  167.  ' only recreated if some propery is changed
  168.  If Not InitConfig() Then
  169.     Exit Function
  170.   End If
  171.  
  172.   On Local Error GoTo Catch
  173.  
  174.   ' create the new email message
  175.  RaiseEvent Notice("Creating a new e-mail message")
  176.   set objMsg = CreateObject("CDO.Message")
  177.   With objMsg
  178.     Set .Configuration = mobjCDOcfg
  179.     ' base infos
  180.    .From = sFrom
  181.     .To = sTo
  182.     .Cc = sCc
  183.     .BCc = sBcc
  184.     .Subject = sSubject
  185.     .TextBody = sBody
  186.     ' handle HTML body (if any)
  187.    If nHtmlType <> htNone Then
  188.       Select Case nHtmlType
  189.         Case htHTML
  190.           ' straight HTML code string
  191.          .HTMLBody = sHtmlData
  192.         Case htURL
  193.           ' from URL
  194.          RaiseEvent Notice("Creating HTML body from " & sHtmlData)
  195.           .CreateMHTMLBody sHtmlData
  196.         Case htFile
  197.           ' from file pathname
  198.          sFile = "file://" & Replace(sHtmlData, "\", "/")
  199.           RaiseEvent Notice("Creating HTML body from " & sFile)
  200.           .CreateMHTMLBody sFile
  201.       End Select
  202.     End If
  203.     ' Attachments
  204.    If Not IsMissing(colAttach) Then
  205.       For Each vItem in colAttach
  206.         sFile = Trim(vItem)
  207.         If Len(sFile) > 0 Then
  208.           RaiseEvent Notice("Adding attachment " & sFile)
  209.           .Addattachment sFile ' full pathname NO relative one
  210.        End If
  211.       Next
  212.     End If
  213.     ' Return receipts
  214.    If (nReceipt <> rfNever) And (nReceipt <> rfDefault) Then
  215.       sConf = "urn:schemas:mailheader:"
  216.       .Fields(sConf & "disposition-notification-to") = sFrom
  217.       .Fields(sConf & "return-receipt-to") = sFrom
  218.     End If
  219.     .DSNOptions = nReceipt
  220.     .Fields.update
  221.   End With
  222.  
  223.   ' send the message
  224.  RaiseEvent Notice("Sending the e-mail message")
  225.   objMsg.Send
  226.   bResult = True
  227.   RaiseEvent Notice("E-mail message successfully sent")
  228.  
  229. BailOut:
  230.   ' common exit
  231.  Set objMsg = Nothing
  232.   SendMail = bResult
  233.   Exit Function
  234.  
  235. Catch:  
  236.   ' got an error
  237.  SetError Err.Number, Err.Description, "CDO message"
  238.   bResult = False
  239.   Resume BailOut
  240. End Function
  241.  
  242. ' ================================================================
  243. ' PRIVATE CODE
  244. ' ================================================================
  245.  
  246. ' initialize the CDO configuration
  247. Private Function InitConfig() As Boolean
  248.   Dim sConf As String
  249.   Dim objFlds As Object
  250.   Dim bResult As Boolean
  251.  
  252.   ' need to reconfigure the CDO ?
  253.  If mbReconfig = False Then
  254.     InitConfig = True
  255.     Exit Function
  256.   End If
  257.  
  258.   On Local Error GoTo Catch
  259.  
  260.   ' initialize, notice how the server port is automatically
  261.  ' selected (if set to 0) according to the SSL flag
  262.  bResult = False
  263.   sConf = "http://schemas.microsoft.com/cdo/configuration/"
  264.   If mlPort = 0 Then
  265.     If mbUseSSL Then
  266.       mlPort = 465  ' SMTP over SSL
  267.    Else
  268.       mlPort = 25   ' standard SMTP
  269.    End If
  270.   End If
  271.  
  272.   RaiseEvent Notice("Configuring SMTP server " & msServer & ":" & mlPort)
  273.  
  274.   ' instance the configuration object
  275.  Set mobjCDOcfg = Nothing
  276.   Set mobjCDOcfg = CreateObject("CDO.Configuration")
  277.  
  278.   ' set configuration
  279.  Set objFlds = mobjCDOcfg.Fields
  280.   With objFlds
  281.     .Item(sConf & "sendusing") = 2 ' cdoSendUsingPort
  282.    .Item(sConf & "smtpserver") = msServer
  283.     .Item(sConf & "smtpusessl") = mbUseSSL
  284.     .Item(sConf & "smtpserverport") = mlPort
  285.     .Item(sConf & "smtpconnectiontimeout") = mlTimeOut
  286.     .Item(sConf & "smtpauthenticate") = mnAuthMode
  287.     If mnAuthMode = amAnonymous Then
  288.       ' no authentication
  289.      .Item(sConf & "sendusername") = ""
  290.       .Item(sConf & "sendpassword") = ""
  291.     Else
  292.       ' use authentication
  293.      .Item(sConf & "sendusername") = msUser
  294.       .Item(sConf & "sendpassword") = msPass
  295.     End If
  296.     .Update
  297.   End With
  298.  
  299.   ' all ok
  300.  RaiseEvent Notice("Configuration complete")
  301.   mbReconfig = False
  302.   bResult = True
  303.  
  304. BailOut:
  305.   ' common exit
  306.  Set objFlds = Nothing
  307.   InitConfig = bResult
  308.   Exit Function
  309.  
  310. Catch:
  311.   ' got an error
  312.  SetError Err.Number, Err.Description, "CDO configuration"
  313.   bResult = False
  314.   Resume BailOut
  315. End Function
  316.  
  317. ' store and signal an error
  318. Private Sub SetError(ByVal lNum As Long, _
  319.                      ByVal sMsg As String, _
  320.                      ByVal sInfo As String)
  321.   mlErrNum = lNum
  322.   msErrMsg = sMsg
  323.   msErrInfo = sInfo
  324.   If lNum <> 0 Then
  325.     RaiseEvent Failure(lNum, sMsg, sInfo)
  326.   End If
  327. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement