Advertisement
Guest User

CSendMail.cls

a guest
Dec 1st, 2017
136
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1.  
  2. Option Explicit
  3.  
  4. ' SMTP 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. ' events
  30. Public Event Failure(ByVal lNum As Long, ByVal sMsg As String, ByVal sInfo As String)
  31. Public Event Warning(ByVal sMsg As String)
  32. Public Event Notice(ByVal sMsg As String)
  33.  
  34. ' internal constants
  35. Private Const DEFAULT_SERVER As String = "localhost"
  36. Private Const DEFAULT_PORT As Long = 0
  37. Private Const DEFAULT_TIMEOUT As Long = 30
  38. Private Const FILE_URL As String = "file://"
  39. Private Const MSG_HEADERS As String = "urn:schemas:mailheader:"
  40. Private Const CDO_CONFIG As String = "http://schemas.microsoft.com/cdo/configuration/"
  41. Private Const SMTP_PORT As Long = 25
  42. Private Const SMTP_SSL_PORT As Long = 465
  43. Private Const SMTP_SEND_MODE As Long = 2 ' cdoSendUsingPort
  44.  
  45. ' server configuration
  46. Private msServer    As String
  47. Private mlPort      As Long
  48. Private mlTimeOut   As Long
  49. Private mbUseSSL    As Boolean
  50. Private mnAuthMode  As enAuthMode
  51. Private msUser      As String
  52. Private msPass      As String
  53.  
  54. ' last error data
  55. Private mlErrNum    As Long
  56. Private msErrMsg    As String
  57. Private msErrInfo   As String
  58.  
  59. ' CDO configuration
  60. Private mbReconfig  As Boolean
  61. Private mobjCDOcfg  As Object
  62.  
  63. ' other stuff
  64. Private objFSO      As Object
  65.  
  66. ' ================================================================
  67. ' CLASS INSTANCE
  68. ' ================================================================
  69.  
  70. ' constructor
  71. Private Sub Class_Initialize()
  72.   On Local Error Resume Next
  73.   mbReconfig = True
  74.   msServer = DEFAULT_SERVER
  75.   mlPort = DEFAULT_PORT
  76.   mlTimeOut = DEFAULT_TIMEOUT
  77.   mbUseSSL = False
  78.   mnAuthMode = amAnonymous
  79.   msUser = ""
  80.   msPass = ""
  81.   SetError 0, "", ""
  82.   Err.Clear
  83.   Set objFSO = CreateObject("Scripting.FileSystemObject")
  84.   If Err.Number <> 0 Then
  85.     SetError Err.Number, Err.Description, "Initialize"
  86.   End If
  87. End Sub
  88.  
  89. ' destructor
  90. Private Sub Class_Terminate()
  91.   Set mobjCDOcfg = Nothing
  92.   Set objFSO = Nothing
  93. End Sub
  94.  
  95. ' ================================================================
  96. ' PUBLIC PROPERTIES
  97. ' ================================================================
  98.  
  99. ' server name or IP
  100. Public Property Let Server(ByVal sServer As String)
  101.   msServer = Trim(sServer)
  102.   If Len(msServer) < 1 Then
  103.     msServer = DEFAULT_SERVER
  104.   End If
  105.   mbReconfig = True
  106. End Property
  107.  
  108. ' port number, 0=autoconfig
  109. Public Property Let Port(ByVal lPort As Long)
  110.   mlPort = lPort
  111.   If (mlPort < 1) Or (mlPort > 65535) Then
  112.     mlPort = DEFAULT_PORT
  113.   End If
  114.   mbReconfig = True
  115. End Property
  116.  
  117. ' connection timeout
  118. Public Property Let ConnTimeOut(ByVal lTimeOut As Long)
  119.   mlTimeOut = lTimeOut
  120.   If mlTimeOut < 0 Then
  121.     mlTimeOut = DEFAULT_TIMEOUT
  122.   End If
  123.   mbReconfig = True
  124. End Property
  125.  
  126. ' true to use SSL (not TLS, CDO doesn't support it)
  127. Public Property Let UseSSL(ByVal bYesNo As Boolean)
  128.   mbUseSSL = bYesNo
  129.   mbReconfig = True
  130. End Property
  131.  
  132. ' authentication mode
  133. Public Property Let AuthMode(ByVal nMode As enAuthMode)
  134.   mnAuthMode = nMode
  135.   mbReconfig = True
  136. End Property
  137.  
  138. ' user name
  139. Public Property Let User(ByVal sUser As String)
  140.   msUser = Trim(sUser)
  141.   mbReconfig = True
  142. End Property
  143.  
  144. ' password
  145. Public Property Let Password(ByVal sPassword As String)
  146.   msPass = Trim(sPassword)
  147.   mbReconfig = True
  148. End Property
  149.  
  150. ' last error number
  151. Public Property Get ErrNum() As Long
  152.   ErrNum = mlErrNum
  153. End Property
  154.  
  155. ' last error message
  156. Public Property Get ErrMsg() As String
  157.   ErrMsg = msErrMsg
  158. End Property
  159.  
  160. ' last error informations
  161. Public Property Get ErrInfo() As String
  162.   ErrInfo = msErrInfo
  163. End Property
  164.  
  165. ' ================================================================
  166. ' PUBLIC METHODS
  167. ' ================================================================
  168.  
  169. ' send an email message
  170. Public Function SendMail(ByVal sFrom As String, _
  171.                          ByVal sTo As String, _
  172.                          ByVal sCc As String, _
  173.                          ByVal sBCc As String, _
  174.                          ByVal sSubject As String, _
  175.                          ByVal sTextBody As String, _
  176.                          Optional ByVal nReceipt As enReceiptFlags = rfDefault,
  177.                          Optional ByVal nHtmlType = htNone
  178.                          Optional ByVal sHtmlData As String = "", _
  179.                          Optional ByVal colAttach As Collection
  180.                          ) As Boolean
  181.   Dim objMsg As Object
  182.   Dim sConf As String, sFile As String, sURL As String
  183.   Dim vItem As Variant
  184.   Dim bResult As Boolean
  185.  
  186.   ' init
  187.  bResult = False
  188.   SendMail = bResult
  189.   SetError 0, "", ""
  190.  
  191.  
  192.   ' check if the config needs to be initialized
  193.  ' this is done once so that sending multiple
  194.  ' mail messages will be faster, the config is
  195.  ' only recreated if some propery is changed
  196.  If Not InitConfig() Then
  197.     Exit Function
  198.   End If
  199.  
  200.   On Local Error GoTo Catch
  201.  
  202.   ' run some checks and raise warnings
  203.  If Len(Trim(sFrom)) = 0 Then
  204.     RaiseEvent Warning("No sender address")
  205.   End If
  206.   sConf = Trim(sTo) & Trim(sCc) & Trim(sBCc)
  207.   If Len(sConf) = 0 Then
  208.     RaiseEvent Warning("No recipient address")
  209.   End If
  210.   If Len(Trim(sSubject)) < 1 Then
  211.     RaiseEvent Warning("Empty subject")
  212.   End If
  213.   If Len(Trim(sTextBody)) < 1 Then
  214.     RaiseEvent Warning("Empty text body")
  215.   End If
  216.  
  217.   ' create the new email message
  218.  RaiseEvent Notice("Creating a new e-mail message")
  219.   set objMsg = CreateObject("CDO.Message")
  220.   With objMsg
  221.     Set .Configuration = mobjCDOcfg
  222.     ' base infos
  223.    .From = sFrom
  224.     .To = sTo
  225.     .Cc = sCc
  226.     .BCc = sBcc
  227.     .Subject = sSubject
  228.     .TextBody = sBody
  229.     ' handle HTML body (if any)
  230.    If nHtmlType <> htNone Then
  231.       Select Case nHtmlType
  232.         Case htHTML
  233.           ' straight HTML code string
  234.          .HTMLBody = sHtmlData
  235.         Case Else
  236.           sURL = sHtmlData
  237.           If nHtmlType = htFile Then
  238.             sFile = GetFileName(sURL)
  239.             If Len(sFile) > 0 Then
  240.               sURL = FILE_URL & Replace(sFile, "\", "/")
  241.             Else
  242.               RaiseEvent Warning("HTML file not found: " & sURL)
  243.               sURL = ""
  244.             End If
  245.           End If
  246.           If Len(sURL) > 0 Then
  247.             RaiseEvent Notice("Creating HTML body from " & sURL)
  248.             .CreateMHTMLBody sURL
  249.           End If
  250.       End Select
  251.     End If
  252.     ' Attachments
  253.    If Not IsMissing(colAttach) Then
  254.       For Each vItem in colAttach
  255.         sFile = Trim(vItem)
  256.         If Len(sFile) > 0 Then
  257.           sFile = GetFileName(sFile)
  258.           If Len(sFile) > 0 Then
  259.             RaiseEvent Notice("Adding attachment " & sFile)
  260.             .Addattachment sFile
  261.           Else
  262.             RaiseEvent Warning("Attachment not found: " & vItem)
  263.           End If
  264.         End If
  265.       Next
  266.     End If
  267.     ' Return receipts
  268.    If (nReceipt <> rfNever) And (nReceipt <> rfDefault) Then
  269.       sConf = MSG_HEADERS
  270.       .Fields(sConf & "disposition-notification-to") = sFrom
  271.       .Fields(sConf & "return-receipt-to") = sFrom
  272.     End If
  273.     .DSNOptions = nReceipt
  274.     .Fields.update
  275.   End With
  276.  
  277.   ' send the message
  278.  RaiseEvent Notice("Sending the e-mail message")
  279.   objMsg.Send
  280.   bResult = True
  281.   RaiseEvent Notice("E-mail message successfully sent")
  282.  
  283. BailOut:
  284.   ' common exit
  285.  Set objMsg = Nothing
  286.   SendMail = bResult
  287.   Exit Function
  288.  
  289. Catch:  
  290.   ' got an error
  291.  SetError Err.Number, Err.Description, "CDO message"
  292.   bResult = False
  293.   Resume BailOut
  294. End Function
  295.  
  296. ' ================================================================
  297. ' PRIVATE CODE
  298. ' ================================================================
  299.  
  300. ' initialize the CDO configuration
  301. Private Function InitConfig() As Boolean
  302.   Dim sConf As String
  303.   Dim objFlds As Object
  304.   Dim bResult As Boolean
  305.  
  306.   ' need to reconfigure the CDO ?
  307.  If mbReconfig = False Then
  308.     InitConfig = True
  309.     Exit Function
  310.   End If
  311.  
  312.   On Local Error GoTo Catch
  313.  
  314.   ' initialize, notice how the server port is automatically
  315.  ' selected (if set to 0) according to the SSL flag
  316.  bResult = False
  317.   If mlPort = DEFAULT_PORT Then
  318.     If mbUseSSL Then
  319.       mlPort = SMTP_SSL_PORT  ' SMTP over SSL
  320.    Else
  321.       mlPort = SMTP_PORT      ' standard SMTP
  322.    End If
  323.   End If
  324.  
  325.  
  326.   RaiseEvent Notice("Configuring SMTP server " & msServer & ":" & mlPort)
  327.  
  328.   ' instance the configuration object
  329.  Set mobjCDOcfg = Nothing
  330.   Set mobjCDOcfg = CreateObject("CDO.Configuration")
  331.  
  332.   ' set configuration
  333.  sConf = CDO_CONFIG
  334.   Set objFlds = mobjCDOcfg.Fields
  335.   With objFlds
  336.     .Item(sConf & "sendusing") = SMTP_SEND_MODE
  337.     .Item(sConf & "smtpserver") = msServer
  338.     .Item(sConf & "smtpusessl") = mbUseSSL
  339.     .Item(sConf & "smtpserverport") = mlPort
  340.     .Item(sConf & "smtpconnectiontimeout") = mlTimeOut
  341.     .Item(sConf & "smtpauthenticate") = mnAuthMode
  342.     If mnAuthMode = amAnonymous Then
  343.       ' no authentication
  344.      .Item(sConf & "sendusername") = ""
  345.       .Item(sConf & "sendpassword") = ""
  346.     Else
  347.       ' use authentication
  348.      .Item(sConf & "sendusername") = msUser
  349.       .Item(sConf & "sendpassword") = msPass
  350.       If (Len(msUser)<1) Or (Len(msPass)<1) Then
  351.         RaiseEvent Warning("Empty Username or Password")
  352.       End If
  353.     End If
  354.     .Update
  355.   End With
  356.  
  357.   ' all ok
  358.  RaiseEvent Notice("Configuration complete")
  359.   mbReconfig = False
  360.   bResult = True
  361.  
  362. BailOut:
  363.   ' common exit
  364.  Set objFlds = Nothing
  365.   InitConfig = bResult
  366.   Exit Function
  367.  
  368. Catch:
  369.   ' got an error
  370.  SetError Err.Number, Err.Description, "CDO configuration"
  371.   bResult = False
  372.   Resume BailOut
  373. End Function
  374.  
  375. ' store and signal an error
  376. Private Sub SetError(ByVal lNum As Long, _
  377.                      ByVal sMsg As String, _
  378.                      ByVal sInfo As String)
  379.   mlErrNum = lNum
  380.   msErrMsg = sMsg
  381.   msErrInfo = sInfo
  382.   If lNum <> 0 Then
  383.     RaiseEvent Failure(lNum, sMsg, sInfo)
  384.   End If
  385. End Sub
  386.  
  387. ' get the full pathname for a given file
  388. Function GetFileName(ByVal sPathName As String) As String
  389.   Dim fi As Object
  390.   Dim sFullName As String
  391.  
  392.   On Local Error Resume Next
  393.   GetFileName = ""
  394.   If Not objFSO.FileExists(sPathName) Then
  395.     Exit Function
  396.   End If  
  397.   Set fi = objFSO.GetFile(sPathName)
  398.   sFullName = fi.Path
  399.  
  400.   Set fi = Nothing
  401.   GetFileName = sFullName
  402. End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement