' Code: Dmitry Stremkouski 
' Date: 11.12.2006
' License: GPL
' Usage: Configure and run

' example:
' cscript //nologo Inbox_ac.vbs

Dim serv1, serv2, usern1, suv1, suv1pw, url1, dateFilter

'/------------------------------------------\
'|         Configuring Script Here.         |
'|------------------------------------------|
'|                                          |
'|       Servers must be predefined !       |
'|------------------------------------------|
		serv1 = "..."              '|
		serv2 = "..."              '|
'|------------------------------------------|
'|                                          |
'|       Username, optionaly for test       |
'|------------------------------------------|
		usern1 = "..."             '|
'|------------------------------------------|
'|                                          |
'| Postmaster's login must be predefined    |
'|------------------------------------------|
		suv1 = "..."               '|
'|------------------------------------------|
'|                                          |
'| Postmaster's password must be predefined |
'|------------------------------------------|
		suv1pw = "..."             '|
'|------------------------------------------|
'|                                          |
'|   Filter date, over that messages stay   |
'|------------------------------------------|
    dateFilter = "2006-11-27T07:55:00Z"    '|
'|------------------------------------------|
'|           End of configuration           |
'\------------------------------------------/

url1 = "http://" & serv1 & "/exchange/" & usern1 & "/"

DoXML

Public Function predateit(datetocon)
strDateTime = year(datetocon) & "-"
if (Month(datetocon) < 10) then strDateTime = strDateTime & "0"
strDateTime = strDateTime & Month(datetocon) & "-"
if (Day(datetocon) < 10) then strDateTime = strDateTime & "0"
strDateTime = strDateTime & Day(datetocon) & "Z-"
predateit = strDateTime
end Function

Public Sub DoXML
Dim objX, strR
Set objX = CreateObject("Microsoft.XMLHTTP")
objX.Open "PROPFIND", url1, FALSE, suv1, suv1pw

strR = "<?xml version=""1.0""?>"
strR = strR & "<d:propfind xmlns:d=""DAV:"" xmlns:e=""urn:schemas:httpmail:"">"
strR = strR & "<d:prop><e:inbox/></d:prop>"
strR = strR & "</d:propfind>"
objX.SetRequestHeader "Content-type:", "text/xml"
objX.SetRequestHeader "Depth", "0"
objX.send(strR)

set docback = objX.responseXML
set objX = Nothing

Dim objNodeList
Set objNodeList = docback.getElementsByTagName("d:inbox")
  Set objNode = objNodeList.nextNode
  ListIt(objNode.nodeTypedValue)
  Set objNode = Nothing
End Sub

Public Sub ListIt(seUrl)

   Dim oXMLHttp
   Dim oXMLDoc
   Dim oXMLHREFNodes
   Dim oXMLHasSubsNodes
   Dim sQuery

   Set oXMLHttp = CreateObject("Microsoft.xmlhttp")
   If Err.Number <> 0 Then
      WScript.Echo "Error Creating XML object"
      WScript.Echo Err.Number & ": " & Err.Description
      Set oXMLHttp = Nothing
   End If

   oXMLHttp.open "SEARCH", seUrl, False, suv1, suv1pw
   If Err.Number <> 0 Then
      WScript.Echo "Error opening DAV connection"
      WScript.Echo Err.Number & ": " & Err.Description
      Set oXMLHttp = Nothing
   End If

   sQuery = "<?xml version=""1.0""?>"
   sQuery = sQuery & "<g:searchrequest xmlns:g=""DAV:"">"
   sQuery = sQuery & "<g:sql>"
   sQuery = sQuery & "SELECT ""DAV:displayname"", ""DAV:href"", ""urn:schemas:httpmail:datereceived"" "
   sQuery = sQuery & " FROM SCOPE('shallow traversal of """ & seURL & """')" 
   sQuery = sQuery & " WHERE ""DAV:isfolder"" = False AND "
   sQuery = sQuery & " ""DAV:ishidden"" = False AND "
   sQuery = sQuery & " ""urn:schemas:httpmail:datereceived"" &lt; CAST(""" & dateFilter & """ as 'dateTime') "
   sQuery = sQuery & " ORDER BY ""urn:schemas:httpmail:datereceived"" DESC"
   sQuery = sQuery & "</g:sql>"
   sQuery = sQuery & "</g:searchrequest>"

   oXMLHttp.setRequestHeader "Content-Type", "text/xml"
   oXMLHttp.setRequestHeader "Translate", "f"
   oXMLHttp.setRequestHeader "Depth", "0"
   oXMLHttp.setRequestHeader "Content-Length", "" & Len(sQuery)

   oXMLHttp.send sQuery
   If Err.Number <> 0 Then
      WScript.Echo "Error Sending Query"
      WScript.Echo Err.Number & ": " & Err.Description
      Set oXMLHttp = Nothing
   End If 

   Set oXMLDoc = oXMLHttp.responseXML
   Set oXMLHttp = Nothing

   Set oXMLHREFNodes = oXMLDoc.getElementsByTagName("a:href")
   Set oXMLDNNodes = oXMLDoc.getElementsByTagName("a:displayname")
   Set oRecord = oXMLDoc.getElementsbyTagName("d:datereceived")

   For iM = 0 to oRecord.Length - 1
	   MyMove = MoveOut(oXMLHREFNodes.Item(iM).nodeTypedValue, oXMLDNNodes.Item(iM).nodeTypedValue)
   Next

   Set oXMLDoc = Nothing
   Set oXMLHREFNodes = Nothing
   Set oXMLDNNodes = Nothing
   Set oRecord = Nothing
End Sub

Public Function MoveOut(srcURLo,destNameo)

Dim objXo, strRo, url2
url2 = "http://" & serv2 & "/exchange/" & usern1 & "2/"

Set objXo = CreateObject("Microsoft.XMLHTTP")
objXo.Open "PROPFIND", url2 , FALSE, suv1, suv1pw

strRo = "<?xml version=""1.0""?>"
strRo = strRo & "<d:propfind xmlns:d=""DAV:"" xmlns:e=""urn:schemas:httpmail:"">"
strRo = strRo & "<d:prop><e:inbox/></d:prop>"
strRo = strRo & "</d:propfind>"
objXo.SetRequestHeader "Content-type:", "text/xml"
objXo.SetRequestHeader "Depth", "0"
objXo.send(strRo)

Set docbacko = objXo.responseXML
Set objXo = Nothing

Dim objNodeListo, destURLo, dPrefixo
Set objNodeListo = docbacko.getElementsByTagName("d:inbox")
  Set objNodeo = objNodeListo.nextNode
  dPrefix = predateit(now())
  destURL = objNodeo.nodeTypedValue & "/" & destNameo
  WScript.Echo destURL

Set req = CreateObject("Microsoft.xmlhttp")
Set req2 = CreateObject("Microsoft.xmlhttp")
req.Open "GET", srcURLo, false, suv1, suv1pw
req2.Open "PUT", destURL, false, suv1, suv1pw

req.setRequestHeader "Translate","f"
req.Send

req2.setRequestHeader "Destination", destURL

Set stm = createobject("ADODB.Stream")
stm.Open
msgstring = req.responseText

stm.type = 2
stm.Charset = "x-ansi"
stm.writetext msgstring,0
stm.Position = 0
stm.type = 1
req2.Send stm

Set stm = Nothing
Set req = Nothing
Set req2 = Nothing
Set objNodelisto = Nothing

End Function