How To Get and Set a Property on a Public Folder Item Using WebDAV

Private Sub Command1_Click()
sSourceURL = "http://e2kServer/public/Folder1/Test1.eml"

sUserID = "Domain\UserID" 'TO DO Change the UserID.
sPassword = "Password"  'TO DO Change the Password.
sSubject = PropFind(sSourceURL, sUserID, sPassword)
MsgBox sSubject

'To change the subject, uncomment the following line.
'PropPatch sSourceURL, "NewSubject"
End Sub

Function PropFind(ByVal sSourceURL As String, ByVal sUserID As String, ByVal sPassword As String) As String

Dim sReq As String

'TO use MSXML 2.0 use the following DIM/SET statements
Dim XMLreq As XMLHTTP
Set XMLreq = CreateObject("Microsoft.xmlhttp")
Set oDocBack = CreateObject("MICROSOFT.XMLDOM")
   

'To use MSXML 6.0 use the folloiwing DIM/SET statements 
'Dim XMLreq As MSXML2.XMLHTTP60
'Set XMLreq = CreateObject("Msxml2.XMLHTTP.6.0")
'Set oDocBack = CreateObject("MSXML2.DomDocument.6.0")

XMLreq.open "PROPFIND", sSourceURL, False, sUserID, sPassword

'Set the header.
XMLreq.setRequestHeader "Content-Type", "text/xml"
   
sReq = "<?xml version='1.0'?>"
sReq = sReq & "<d:propfind xmlns:d='DAV:' xmlns:m='urn:schemas:mailheader:'><d:prop>"
sReq = sReq & "<m:subject/>"
sReq = sReq & "</d:prop></d:propfind>"

XMLreq.send sReq

Set oDocBack = XMLreq.responseXML
Set objNodeList = oDocBack.getElementsByTagName("d:subject")
PropFind = objNodeList(0).Text

End Function

Sub PropPatch(ByVal sSourceURL As String, ByVal sNewVal As String)

Dim sReq As String

'TO use MSXML 2.0 use the following DIM/SET statements
Dim XMLreq As XMLHTTP
Set XMLreq = CreateObject("Microsoft.xmlhttp")


'To use MSXML 6.0 use the folloiwing SET/DIM statements 
'Dim XMLreq As MSXML2.XMLHTTP60
'Set XMLreq = CreateObject("Msxml2.XMLHTTP.6.0")


   
XMLreq.open "PROPPATCH", sSourceURL, False, sUserID, sPassword

'Set the header.
XMLreq.setRequestHeader "Content-Type", "text/xml"

sReq = "<?xml version='1.0'?>"
sReq = sReq & "<d:propertyupdate xmlns:d='DAV:' xmlns:m='urn:schemas:mailheader:'>"
sReq = sReq & "<d:set><d:prop>"
sReq = sReq & "<m:subject>" & sNewVal & "</m:subject>"
sReq = sReq & "</d:prop></d:set></d:propertyupdate>"
 
XMLreq.send sReq

If XMLreq.Status = 207 Then
    MsgBox "Success"
End If

End Sub