'------------------------------------------------------------------------------------------------------------\
'|                                                                                                           |
'|                     OUT OF OFFICE ADMIN - USING EXCHANGE WEBDAV - FOR VB6 AND VBSCRIPT                    |
'|                                                                                                           |
'|-----------------------------------------------------------------------------------------------------------|
'| CODE CREATED USING VARIOUS BITS OF DOCUMENTATION FROM ACROSS THE WEB:                                     |
'|                                                                                                           |
'| http://www.greycube.com                                                                                   |
'| http://gsexdev.blogspot.com/2004/06/setting-oof-status-and-text-using-owa.html                            |
'| http://www.winserverkb.com/Uwe/Forum.aspx/exchange-development/1941/Getting-out-of-office-message         |
'| http://www.devnewsgroups.net/group/microsoft.public.exchange.development/topic51161.aspx                  |
'------------------------------------------------------------------------------------------------------------/


  Private Function WebDav_OOF_Get_Status(ByVal sMailboxServer, ByVal sMailboxUsername, Optional ByVal sAdminNTName, Optional ByVal sAdminPassword) As Boolean

      Dim sFolderURL As String
      Dim sXMLQuery As Variant
      Dim oXmlHttp As Object
      Dim oXmlDoc As Object
      Dim oXmlNodes As Object
      
      sFolderURL = "http://" & sMailboxServer & "/exchange/" & sMailboxUsername & "/NON_IPM_SUBTREE/"
      
      sXMLQuery = "<?xml version=""1.0"" ?>"
      sXMLQuery = sXMLQuery & vbLf & "<a:propfind xmlns:a=""DAV:"" xmlns:b=""http://schemas.microsoft.com/exchange/"">"
      sXMLQuery = sXMLQuery & vbLf & "<a:prop>"
      sXMLQuery = sXMLQuery & vbLf & "<b:oof-state/>"
      sXMLQuery = sXMLQuery & vbLf & "</a:prop>"
      sXMLQuery = sXMLQuery & vbLf & "</a:propfind>"
      
      Set oXmlHttp = CreateObject("Microsoft.xmlhttp")
      
      oXmlHttp.Open "PROPFIND", sFolderURL, False, sAdminNTName, sAdminPassword
      oXmlHttp.setRequestHeader "Content-Type", "text/xml"
      oXmlHttp.setRequestHeader "Depth", "0"
      oXmlHttp.setRequestHeader "Translate", "f"
      oXmlHttp.setRequestHeader "Content-Length", Len(sXMLQuery)
      oXmlHttp.Send sXMLQuery
          
      Set oXmlDoc = oXmlHttp.responseXml
      
      Set oXmlNodes = oXmlDoc.getElementsByTagName("d:oof-state")
      
      If oXmlNodes.length > 0 Then
          If oXmlNodes.Item(oXmlNodes.length - 1).Text = "1" Then
              WebDav_OOF_Get_Status = True
          End If
      Else
          MsgBox "DEBUG:WebDav_OOF_Get_Status:FAILED:XML Not Returned"
      End If
      
      Set oXmlHttp = Nothing
      Set oXmlDoc = Nothing
      Set oXmlNodes = Nothing

  End Function


'-----------------------------------------------------------------------------------------------------------+


  Function WebDav_OOF_Set_Status(ByVal bStatus, ByVal sMailboxServer, ByVal sMailboxUsername, Optional ByVal sAdminNTName, Optional ByVal sAdminPassword) As Boolean
  On Error GoTo ErrorHandler

      Dim sFolderURL As String
      Dim sXMLQuery As Variant
      Dim oXmlHttp As Object
      
      sFolderURL = "http://" & sMailboxServer & "/exchange/" & sMailboxUsername & "/"

      sXMLQuery = "Cmd=options"

      If bStatus = True Then
          sXMLQuery = sXMLQuery & vbLf & "OofState=1"
      Else
          sXMLQuery = sXMLQuery & vbLf & "OofState=0"
      End If
      
      Set oXmlHttp = CreateObject("Microsoft.xmlhttp")
      
      oXmlHttp.Open "POST", sFolderURL, False, sAdminNTName, sAdminPassword
      oXmlHttp.setRequestHeader "Accept-Language", "en-us"
      oXmlHttp.setRequestHeader "Content-type", "application/x-www-UTF8-encoded"
      oXmlHttp.setRequestHeader "Content-Length", Len(sXMLQuery)
      oXmlHttp.Send sXMLQuery
      
      If oXmlHttp.Status = 200 Then
          WebDav_OOF_Set_Status = True
      Else
          MsgBox "DEBUG:WebDav_OOF_Set_Status:FAILED:" & oXmlHttp.Status
      End If
      
      Set oXmlHttp = Nothing

  End Function


'-----------------------------------------------------------------------------------------------------------+


  Private Function WebDav_OOF_Get_Message(ByVal sMailboxServer, ByVal sMailboxUsername, Optional ByVal sAdminNTName, Optional ByVal sAdminPassword) As String
  On Error GoTo ErrorHandler

      Dim sFolderURL As String
      Dim sXMLQuery As Variant
      Dim oXmlHttp As Object
      Dim oXmlDoc As Object
      Dim oXmlNodes As Object

      sFolderURL = "http://" & sMailboxServer & "/exchange/" & sMailboxUsername & "/inbox/"
      
      sXMLQuery = "<?xml version=""1.0"" encoding=""utf-8"" ?>"
      sXMLQuery = sXMLQuery & vbLf & "<D:searchrequest xmlns:D = ""DAV:"">"
      sXMLQuery = sXMLQuery & vbLf & "<D:sql>"
      sXMLQuery = sXMLQuery & vbLf & "SELECT ""urn:schemas:httpmail:textdescription"" FROM SCOPE('shallow traversal of """ & sFolderURL & """') "
      sXMLQuery = sXMLQuery & vbLf & "WHERE (""DAV:isfolder"" = FALSE) AND (""http://schemas.microsoft.com/exchange/outlookmessageclass"" LIKE '%IPM.Note.Rules.OofTemplate.Microsoft%')"
      sXMLQuery = sXMLQuery & vbLf & "</D:sql>"
      sXMLQuery = sXMLQuery & vbLf & "</D:searchrequest>"

      Set oXmlHttp = CreateObject("Microsoft.xmlhttp")
      
      oXmlHttp.Open "SEARCH", sFolderURL, False, sAdminNTName, sAdminPassword

      oXmlHttp.setRequestHeader "Content-Type", "text/xml"
      oXmlHttp.setRequestHeader "Translate", "f"
      oXmlHttp.setRequestHeader "Depth", "0"
      oXmlHttp.setRequestHeader "Content-Length", Len(sXMLQuery)
      oXmlHttp.Send sXMLQuery
      
      Set oXmlDoc = oXmlHttp.responseXml
      Set oXmlNodes = oXmlDoc.getElementsByTagName("d:textdescription")
      
      If oXmlNodes.length > 0 Then
          WebDav_OOF_Get_Message = oXmlNodes.Item(oXmlNodes.length - 1).Text
      Else
          MsgBox "DEBUG:WebDav_OOF_Get_Message:FAILED:XML Not Returned"
      End If
      
      Set oXmlHttp = Nothing
      Set oXmlDoc = Nothing
      Set oXmlNodes = Nothing

  End Function


'-----------------------------------------------------------------------------------------------------------+


  Private Function WebDav_OOF_Set_Message(ByVal sMessage, ByVal sMailboxServer, ByVal sMailboxUsername, Optional ByVal sAdminNTName, Optional ByVal sAdminPassword) As Boolean
  On Error GoTo ErrorHandler

      Dim sFolderURL As String
      Dim sXMLQuery As Variant
      Dim oXmlHttp As Object
      
      sFolderURL = "http://" & sMailboxServer & "/exchange/" & sMailboxUsername & "/"
      
      sMessage = Replace(sMessage, vbCr, "") ' REMOVE CARRIAGE RETURNS
      sMessage = Replace(sMessage, vbLf, "&#13;") ' CONVERT LINE FEEDS INTO UTF-8

      sXMLQuery = "Cmd=options"
      sXMLQuery = sXMLQuery & vbLf & "OofReply=" & sMessage
      
      Set oXmlHttp = CreateObject("Microsoft.xmlhttp")
      
      oXmlHttp.Open "POST", sFolderURL, False, sAdminNTName, sAdminPassword
      oXmlHttp.setRequestHeader "Accept-Language", "en-us"
      oXmlHttp.setRequestHeader "Content-type", "application/x-www-UTF8-encoded"
      oXmlHttp.setRequestHeader "Content-Length", Len(sXMLQuery)
      oXmlHttp.Send sXMLQuery

      If oXmlHttp.Status = 200 Then
          WebDav_OOF_Set_Message = True
      Else
          MsgBox "DEBUG:WebDav_OOF_Set_Message:FAILED:" & oXmlHttp.Status
      End If
      
      Set oXmlHttp = Nothing

  End Function


'-----------------------------------------------------------------------------------------------------------+