• Home
 · 
• Miscellaneous
 · 
• Code to send email

Code to send email

Code to send email

Rate Code to send email

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

      Dim strSubURL As String
      Dim strAlias As String
      Dim strUserName As String
      Dim strPassWord As String
      Dim strExchSvrName As String
      Dim strFrom As String
      Dim strTo As String
      Dim strSubject As String
      Dim strBody As String
      Dim bResult As Boolean
      
      ' Exchange Server Name.
      strExchSvrName = "ExchangeServerName"
      ' Alias of the sender.
      strAlias = "user1"
      ' User Name of the sender.
      strUserName = "DomainName\user1"
      ' Password of the sender.
      strPassWord = "password"
      ' Email address of the sender.
      strFrom = "[email protected]"
      ' Email address of recipient.
      strTo = "[email protected]"
      ' Subject of the mail.
      strSubject = "Mail Subject"
      ' Text body of the mail.
      strBody = "Mail Body"
      
      strSubURL = FindSubmissionURL(strExchSvrName, _
               strAlias, _
               strUserName, _
               strPassWord)
               
      If strSubURL <> "" Then
         bResult = False
         bResult = SendMail(strSubURL, _
                  strFrom, _
                  strTo, _
                  strSubject, _
                  strBody, _
                  strUserName, _
                  strPassWord)
         If bResult Then
            MsgBox "Successfully send mail via WebDAV!"
         End If
      End If

   End Sub

   Function FindSubmissionURL(strExchSvr, _
          strAlias, _
          strUserName, _
          strPassWord) As String
      
       Dim query As String
     Dim strURL As String
     Dim xmlRoot As IXMLDOMElement
     Dim xmlNode As IXMLDOMNode
     Dim baseName As String

   'To use MSXML 2.0 use the following Dim statements   
      Dim xmlReq As MSXML.XMLHTTPRequest
      Dim xmldom As MSXML.DOMDocument
      Dim xmlAttr As MSXML.IXMLDOMAttribute
    
   'To use MSXML 4.0 use the following Dim statements 
      'Dim xmlReq As MSXML2.XMLHTTP40
      'Dim xmldom As MSXML2.DOMDocument40
      'Dim xmlAttr As MSXML2.IXMLDOMAttribute
      

      'namespacemanager.declarePrefix "d", "urn:schemas:httpmail:"
      'On Error GoTo ErrHandler
      ' Create the DAV PROPFIND request.

      Set xmlReq = CreateObject("Microsoft.XMLHTTP")

   'To use MSXML 4.0 use the following set statement
   '   Set xmlReq = CreateObject("Msxml2.XMLHTTP.4.0")

      strURL = "http://" & strExchSvr & "/exchange/" & strAlias
      
      xmlReq.Open "PROPFIND", strURL, False, strUserName, strPassWord
      xmlReq.setRequestHeader "Content-Type", "text/xml"
      xmlReq.setRequestHeader "Depth", "0"

      query = "<?xml version='1.0'?>"
      query = query + "<a:propfind xmlns:a='DAV:'>"
      query = query + "<a:prop xmlns:m='urn:schemas:httpmail:'>"
      query = query + "<m:sendmsg/>"
      query = query + "</a:prop>"
      query = query + "</a:propfind>"
      
      xmlReq.send (query)
    
     MsgBox xmlReq.Status
      ' process the result
      If (xmlReq.Status >= 200 And xmlReq.Status < 300) Then
        ' MsgBox "Success! " & "PROPFIND Results = " & xmlReq.Status & _
          '     ": " & xmlReq.statusText
            
         Set xmldom = xmlReq.responseXML
            
         Set xmlRoot = xmldom.documentElement  '.documentElement
       'To use MSXML 2.0 use the following code to get the Submission URL 
         For Each xmlAttr In xmlRoot.Attributes
            If xmlAttr.Text = "urn:schemas:httpmail:" Then
               baseName = xmlAttr.baseName
               Exit For
            End If
         Next
         
         Set xmlNode = xmlRoot.selectSingleNode("//" & baseName & ":sendmsg")
         FindSubmissionURL = xmlNode.Text
      
        ' To use MSXML 4.0 use the following lines of code to get the Submission URL 
        ' Dim objNodeList As IXMLDOMNodeList
        ' Set objNodeList = xmlRoot.getElementsByTagName("d:sendmsg")
        ' For i = 0 To (objNodeList.length - 1)
        '   FindSubmissionURL = objNodeList.Item(i).Text
        ' Next
      Else
         MsgBox "Failed to find mail submission URL"
         FindSubmissionURL = ""
      End If

   ErrExit:
      Set xmlReq = Nothing
      Set xmldom = Nothing
      Set xmlRoot = Nothing
      Set xmlNode = Nothing
      Set xmlAttr = Nothing
      Exit Function
   ErrHandler:
      MsgBox Err.Number & ": " & Err.Description
      FindSubmissionURL = ""
   End Function

   'Also change the function... 

   'Function SendMail(strSubURL, _
         'strFrom, _
         'strTo, _
         'strSubject, _
         'strBody, _
         'strUserName, _
         'strPassWord) As Boolean

   '...to the following to accomodate the comments for its use with MSXML 4.0: 

'   Function SendMail(strSubURL, _
'         strFrom, _
'         strTo, _
'         strSubject, _
'         strBody, _
'         strUserName, _
'         strPassWord) As Boolean
         
'        Dim strText

'        Dim xmlReq As MSXML.XMLHTTPRequest
'        Set xmlReq = CreateObject("Microsoft.XMLHTTP")

        ' To use MSXML 4.0 use the followinf DIM/SET statements
        ' Dim xmlReq As MSXML2.XMLHTTP40
        ' Set xmlReq = CreateObject("Msxml2.XMLHTTP.4.0")
      
        ' On Error GoTo ErrHandler
        ' Construct the text of the PUT request
'         strText = "From: " & strFrom & vbNewLine & _
'            "To: " & strTo & vbNewLine & _
'            "Subject: " & strSubject & vbNewLine & _
'            "Date: " & Now & _
'            "X-Mailer: test mailer" & vbNewLine & _
'            "MIME-Version: 1.0" & vbNewLine & _
'            "Content-Type: text/plain;" & vbNewLine & _
'            "Charset = ""iso-8859-1""" & vbNewLine & _
'            "Content-Transfer-Encoding: 7bit" & vbNewLine & _
'            vbNewLine & _
'            strBody
            
         ' Create the DAV PUT request.

'         xmlReq.Open "PUT", strSubURL, False, strUserName, strPassWord
'         If strText <> "" Then
'            xmlReq.setRequestHeader "Content-Type", "message/rfc822"
'            xmlReq.send strText
'         End If
         
         'Process the results.
'         If (xmlReq.Status >= 200 And xmlReq.Status < 300) Then
           ' MsgBox "Success!   " & "PUT Results = " & xmlReq.Status & _
           '    ": " & xmlReq.statusText
'            SendMail = True
'         ElseIf xmlReq.Status = 401 Then
          '  MsgBox "You don't have permission to do the job! " & _
          '     "Please check your permissions on this item."
'            SendMail = False
'         Else
          '  MsgBox "Request Failed.  Results = " & xmlReq.Status & _
            '   ": " & objRequest.statusText
'            SendMail = False
'         End If
'   ErrExit:
'      Set xmlReq = Nothing
'      Exit Function
'   ErrHandler:
'      MsgBox Err.Number & ": " & Err.Description
'      SendMail = False
'   End Function

   Function SendMail(strSubURL, _
         strFrom, _
         strTo, _
         strSubject, _
         strBody, _
         strUserName, _
         strPassWord) As Boolean
         
         Dim xmlReq As MSXML.XMLHTTPRequest
         Dim strText
      
         On Error GoTo ErrHandler
         ' Construct the text of the PUT request.
         strText = "From: " & strFrom & vbNewLine & _
            "To: " & strTo & vbNewLine & _
            "Subject: " & strSubject & vbNewLine & _
            "Date: " & Now & _
            "X-Mailer: test mailer" & vbNewLine & _
            "MIME-Version: 1.0" & vbNewLine & _
            "Content-Type: text/plain;" & vbNewLine & _
            "Charset = ""iso-8859-1""" & vbNewLine & _
            "Content-Transfer-Encoding: 7bit" & vbNewLine & _
            vbNewLine & _
            strBody
            
         ' Create the DAV PUT request.
         Set xmlReq = CreateObject("Microsoft.XMLHTTP")
         xmlReq.Open "PUT", strSubURL, False, strUserName, strPassWord
         If strText <> "" Then
            xmlReq.setRequestHeader "Content-Type", "message/rfc822"
            xmlReq.send strText
         End If
         
         'Process the results.
         If (xmlReq.Status >= 200 And xmlReq.Status < 300) Then
            MsgBox "Success!   " & "PUT Results = " & xmlReq.Status & _
               ": " & xmlReq.statusText
            SendMail = True
         ElseIf xmlReq.Status = 401 Then
            MsgBox "You don't have permission to do the job! " & _
               "Please check your permissions on this item."
            SendMail = False
         Else
            MsgBox "Request Failed.  Results = " & xmlReq.Status & _
               ": " & objRequest.statusText
            SendMail = False
         End If
   ErrExit:
      Set xmlReq = Nothing
      Exit Function
   ErrHandler:
      MsgBox Err.Number & ": " & Err.Description
      SendMail = False
   End Function