1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
|
Option Explicit
' This constant can only be set once, the correct one needs selecting. Disabled the HTTPS Requirement
' for testing.
' Exchange 2007 / 2003 SSL:
' Const WEBDAV_PATH = "https:///exchange"
' Exchange 2007 / 2003 / 2000:
Const WEBDAV_PATH = "http:///exchange"
' Inactive Time for item deletion in Days
Const INACTIVE_TIME = 1
' Debugging. Set to True to enable. Adds extended logging.
Const ENABLE_DEBUG = True
' Reporting. Set to True to enable. Logs basic change details to a file.
Const ENABLE_REPORT = True
' Set to True to enable item deletion.
Const ENABLE_DELETE = False
Function GetDefaultSMTP
' Returns Primary SMTP Domain of Default Recipient Policy. Used to generate path to user mailbox in WebDAV.
Const ADS_SCOPE_SUBTREE = 2
Dim objConnection, objCommand, objRootDSE, objRecordSet
Dim strAddress
Dim arrGatewayProxy
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
Set objRootDSE = GetObject("LDAP://RootDSE")
objCommand.CommandText = "SELECT gatewayProxy " &_
"FROM 'LDAP://" & objRootDSE.Get("configurationNamingContext") &_
"' WHERE objectClass='msExchRecipientPolicy' AND cn='Default Policy'"
If ENABLE_DEBUG = True Then
objDebugFile.WriteLine "[" & Now & "]: Searching Config NC: " &_
objRootDSE.Get("configurationNamingContext")
End If
Set objRootDSE = Nothing
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Timeout") = 600
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.Properties("Cache Results") = False
Set objRecordSet = objCommand.Execute
If objRecordSet.EOF = False Then
arrGatewayProxy = objRecordSet.Fields("gatewayProxy").Value
GetDefaultSMTP = ""
For Each strAddress in arrGatewayProxy
If InStr(strAddress, "SMTP:") > 0 Then
GetDefaultSMTP = Right(strAddress, _
Len(strAddress) - InStr(strAddress, "@") + 1)
End If
Next
ElseIf ENABLE_DEBUG = True Then
objDebugFile.WriteLine "[" & Now & "]: Failed to find Default Recipient Policy"
End If
Set objRecordSet = Nothing
Set objCommand = Nothing
Set objConnection = Nothing
End Function
Sub GetMailboxes
' Populates a Dictionary Object containing all Mailboxes, the mailnickname and DistinguishedName
Const ADS_SCOPE_SUBTREE = 2
Dim objConnection, objCommand, objRootDSE, objRecordSet
Dim strMailNickName, strDN, strDisplayName
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
Set objRootDSE = GetObject("LDAP://RootDSE")
objCommand.CommandText = "SELECT mailNickName, distinguishedName, displayName " &_
"FROM 'LDAP://" & objRootDSE.Get("defaultNamingContext") &_
"' WHERE objectClass='user' AND objectCategory='person' AND mail='*'"
If ENABLE_DEBUG = True Then
objDebugFile.WriteLine "[" & Now & "]: Searching Domain NC: " &_
objRootDSE.Get("defaultNamingContext")
End If
Set objRootDSE = Nothing
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Timeout") = 600
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
objCommand.Properties("Cache Results") = False
Set objRecordSet = objCommand.Execute
Do While Not objRecordSet.EOF
strMailNickName = objRecordSet.Fields("mailNickName").Value
strDN = objRecordSet.Fields("distinguishedName").Value
strDisplayName = ""
If Not IsNull(objRecordSet.Fields("displayName")) Then
strDisplayName = objRecordSet.Fields("displayName").Value
End If
objUsers.Add strDN, Array(strMailNickName, strDisplayName)
objRecordSet.MoveNext
Loop
Set objRecordSet = Nothing
Set objCommand = Nothing
Set objConnection = Nothing
End Sub
Sub TraverseMailbox(strURL, strDN, k)
Dim objRequest, objXMLDocument, objHREFNodes, objHasSubNodes
Dim strQuery
Dim i
Dim blnError
Set objRequest = CreateObject("Microsoft.XMLHTTP")
objRequest.Open "SEARCH", strURL, False
strQuery = "" &_
"" &_
"SELECT ""http://schemas.microsoft.com/" &_
"mapi/proptag/x0e080003"", ""DAV:hassubs"" FROM SCOPE " &_
"('SHALLOW TRAVERSAL OF """ & strURL & """') " &_
"WHERE ""DAV:isfolder"" = TRUE AND ""DAV:ishidden"" = FALSE AND " &_
"""http://schemas.microsoft.com/mapi/proptag/x36010003"" = 1" &_
"" &_
""
On Error Resume Next
' Most likely problem here will be Access Denied.
' May be possible to bypass using EXAdmin Virtual Directory on earlier versions of Exchange.
' Exchange 2007 exhibits same Access issues regardless of Virtual Directory used
blnError = False
objRequest.SetRequestHeader "Content-Type", "text/xml"
objRequest.SetRequestHeader "Translate", "f"
objRequest.Send strQuery
If objRequest.Status <> 207 Then
objDebugFile.WriteLine "[" & Now & "]: Error: " & strURL & ": " & objRequest.Status
blnError = True
End If
If Err.Number <> 0 Then
' Echo the connection URL and the Error Message
If ENABLE_DEBUG = True Then
objDebugFile.WriteLine "[" & Now & "] Connection Error"
objDebugFile.WriteLine strURL & ": " & Err.Description
End If
blnError = True
End If
On Error Goto 0
' No point in trying to get the items if we didn't get access to the mailbox.
If blnError = False Then
If k = 0 Then
k = k + 1
If ENABLE_REPORT = True Then
objReport.Add strDN, 0
End If
End If
Set objXMLDocument = objRequest.ResponseXML
Set objHREFNodes = objXMLDocument.GetElementsByTagName("a:href")
Set objHasSubNodes = objXMLDocument.GetElementsByTagName("a:hassubs")
' For Each Folder in the Mailbox
For i = 0 to (objHREFNodes.Length - 1)
' Call CheckMessages passing the current folder path (URL)
CheckMessages objHREFNodes.Item(i).NodeTypedValue, strDN
If objHasSubNodes.Item(i).NodeTypedValue = True Then
' If the current folder has Sub Folders pass
' the URL back to this Subroutine to capture contents.
TraverseMailbox objHREFNodes.Item(i).NodeTypedValue, strDN, k
End If
Next
End If
Set objRequest = Nothing
End Sub
Sub CheckMessages(strURL, strDN)
Dim objRequest, objXMLDocument, objHREFs, objReceivedDates
Dim objHREF, objReceivedDate
Dim strQuery
Dim dtmReceivedDate
Dim i
Set objRequest = CreateObject("Microsoft.XMLHTTP")
objRequest.Open "SEARCH", strURL, False
' Create Query to return all Unread Mail in the current folder (strURL)
strQuery = "" &_
"" &_
"SELECT ""DAV:displayname"", ""urn:schemas:httpmail:subject"", " &_
"""DAV:creationdate"", ""DAV:getcontentlength"", " &_
"""urn:schemas:httpmail:fromemail""" &_
" FROM scope('SHALLOW TRAVERSAL OF """ & strURL &_
"""') WHERE ""DAV:ishidden"" = FALSE AND ""DAV:isfolder"" = FALSE " &_
"AND ""urn:schemas:httpmail:read"" = FALSE"
objRequest.SetRequestHeader "Content-Type", "text/xml"
objRequest.SetRequestHeader "Translate", "f"
objRequest.Send strQuery
If objRequest.Status = 207 Then
' Return objects containing all named elements from the XML stream
Set objXMLDocument = objRequest.ResponseXML
' Uncomment to echo the XML returned by the Query. Only used to add fields.
' WScript.Echo objRequest.ResponseText
Set objHREFs = objXMLDocument.GetElementsByTagName("a:href")
Set objReceivedDates = objXMLDocument.GetElementsByTagName("a:creationdate")
' Doesn't matter which one we choose for Length, all return the same
For i = 0 To (objReceivedDates.Length - 1)
' Get the Received Date
Set objReceivedDate = objReceivedDates.NextNode
dtmReceivedDate = CDate(Left(objReceivedDate.Text, InStr(objReceivedDate.Text, "T") - 1))
If dtmReceivedDate <= (Date - INACTIVE_TIME) Then
Set objHREF = objHREFs.NextNode
If ENABLE_DEBUG = True Then
objDebugFile.WriteLine "[" & Now & "]: Calling Delete for: " & objHREF.Text
objDebugFile.WriteLine "[" & Now & "]: Date: " & dtmReceivedDate & " (vs " &_
(Date - INACTIVE_TIME) & ")"
End If
If ENABLE_REPORT = True Then
objReport(strDN) = objReport(strDN) + 1
End If
DeleteItem objHREF.Text
End If
Next
End If
Set objRequest = Nothing
End Sub
Sub DeleteItem(strURL)
Dim objRequest
Set objRequest = CreateObject("Microsoft.XMLHTTP")
If ENABLE_DELETE = True Then
' Deletes strURL
objRequest.Open "DELETE", strURL, False
objRequest.Send
If ENABLE_DEBUG = True Then
objDebugFile.WriteLine "[" & Now & "]: Executing Delete: " & strURL
objDebugFile.WriteLine objRequest.Status
End If
End If
Set objRequest = Nothing
End Sub
'
' Main Code
'
Dim objFileSystem, objDebugFile, objReport, objReportFile, objUsers
Dim strDefaultSMTPDomain, strDN
Dim dtmRuntime
' Configure Debug and Report Files
If ENABLE_DEBUG = True Or ENABLE_REPORT = True Then
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
If ENABLE_DEBUG = True Then
Set objDebugFile = objFileSystem.OpenTextFile(WScript.Scriptname & "_Debug.log", 2, True, 0)
objDebugFile.WriteLine "[" & Now & "]: Script Started. Debug Enabled."
dtmRuntime = Now
End If
If ENABLE_REPORT = True Then
Set objReport = CreateObject("Scripting.Dictionary")
Set objReportFile = objFileSystem.OpenTextFile(WScript.Scriptname & "_Report.log", 2, True, 0)
End If
End If
' Get the Default SMTP Domain from the Default Recipient Policy
strDefaultSMTPDomain = GetDefaultSMTP
If ENABLE_DEBUG = True Then
objDebugFile.WriteLine "[" & Now & "]: Default SMTP Domain: " & strDefaultSMTPDomain
End If
Set objUsers = CreateObject("Scripting.Dictionary")
GetMailboxes
If objUsers.Count > 0 Then
For Each strDN in objUsers
' Call Subroutine to connect to Mailbox and follow folder path. Pass DN and 0 for Reporting and pass number.
' Pass Number - Used to write reporting field on first pass through subroutine
TraverseMailbox WEBDAV_PATH & "/" & objUsers(strDN)(0) & strDefaultSMTPDomain, strDN, 0
Next
End If
If ENABLE_REPORT = True Then
objReportFile.WriteLine "Display Name" & VbTab & "Items Deleted" & VbTab & "Distinguished Name"
For Each strDN in objUsers
If objReport.Exists(strDN) Then
objReportFile.WriteLine objUsers(strDN)(1) & VbTab & objReport(strDN) & VbTab & strDN
Else
objReportFile.WriteLine objUsers(strDN)(1) & VbTab & "Connect Failed" & VbTab & strDN
End If
Next
End If
If ENABLE_DEBUG = True Then
dtmRuntime = DateDiff("s", dtmRuntime, Now)
objDebugFile.WriteLine "[" & Now & "]: Script Execution Time: " & dtmRuntime & " seconds"
End If
Set objUsers = Nothing
Set objReport = Nothing
Set objReportFile = Nothing
Set objDebugFile = Nothing
Set objFileSystem = Nothing
|
