Help and Support
 

powered byLive Search

How To Send a Message from Visual Basic by Using WebDAV

View products that this article applies to.
Article ID:296713
Last Review:February 22, 2007
Revision:3.2
This article was previously published under Q296713

SUMMARY

This article demonstrates how to use WebDAV's PROPFIND and PUT methods to send an e-mail message from Visual Basic.

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.
APPLIES TO
•Microsoft Exchange 2000 Server Standard Edition
•Microsoft XML Parser 2.0
•Microsoft Visual Basic Enterprise Edition for Windows 6.0
•Microsoft Visual Basic 6.0 Professional Edition

Back to the top

Keywords: 
kbhowto kbmsg KB296713

Article Translations

 

Related Support Centers

Other Support Options

  • Need More Help?
    Contact a Support professional by E-mail, Online or Phone.
  • Customer Service
    For non-technical assistance with product purchases, subscriptions, online services, events, training courses, corporate sales, piracy issues, and more.
  • Newsgroups
    Pose a question to other users. Discussion groups and Forums about specific Microsoft products, technologies, and services.