How To Send a Message from Visual Basic by Using WebDAV (296713)

MORE INFORMATION

E-mail messages can be sent by using a special Uniform Resource Identifier (URI) that is called the Exchange mail submission URI. A user's mail submission URI is found by using WebDAV PROPFIND method to retrieve the value of the urn:schemas:httpmail:sendmsg property of the user's private mailbox folder. The WebDAV PUT method can then be used to put a message stream into this mail submission URI.

To use WebDAV to send a message from Visual Basic, follow these steps:

1. In Visual Basic, create a new Standard EXE project.
2. Add a button to the default form and name it Command1.
3. Paste the following code into the view code window:

     Private Sub Command1_Click()
         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 = "user1@somewhere.com"
         ' Email address of recipient.
         strTo = "user2@somewhere.com"
         ' 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
    
   					

4. In the code, change strExchSvrName, strAlias, strUserName, strPassWord, strFrom, and strTo according to your situation.
5. Add a reference to the Microsoft XML version 2.0 Library.
6. Run the program and click the button.
7. Verify that the email message has been sent and received.