On Error Resume Next
servername = WScript.arguments(0)
PR_HAS_RULES = &H663A000B
PR_URL_NAME = &H6707001E
PR_CREATOR = &H3FF8001E
Set fso = CreateObject("Scripting.FileSystemObject")
Set wfile = fso.opentextfile("c:\forwardingRules.ini",2,True)
'wfile.writeline("Mailbox,FolderPath,Creator,AdressObject,SMTPForwdingAddress")
Set conn = CreateObject("ADODB.Connection")
Set com = CreateObject("ADODB.Command")
Set iAdRootDSE = GetObject("LDAP://RootDSE")
strNameingContext = iAdRootDSE.Get("configurationNamingContext")
strDefaultNamingContext = iAdRootDSE.Get("defaultNamingContext")
Conn.Provider = "ADsDSOObject"
Conn.Open "ADs Provider"
svcQuery = "<LDAP://" & strNameingContext & ">;(&(objectCategory=msExchExchangeServer)(cn=" & Servername & "));cn,name,legacyExchangeDN;subtree"
Com.ActiveConnection = Conn
Com.CommandText = svcQuery
Set Rs = Com.Execute
While Not rs.eof
GALQueryFilter = "(&(&(&(& (mailnickname=*)(!msExchHideFromAddressLists=TRUE)(| (&(objectCategory=person)(objectClass=user)(msExchHomeServerName=" & rs.fields("legacyExchangeDN") & ")) )))))"
strQuery = "<LDAP://" & strDefaultNamingContext & ">;" & GALQueryFilter & ";distinguishedName,mailnickname;subtree"
com.Properties("Page Size") = 100
Com.CommandText = strQuery
Set Rs1 = Com.Execute
While Not Rs1.eof
Call procmailboxes(servername,rs1.fields("mailnickname"))
WScript.echo rs1.fields("mailnickname")
rs1.movenext
Wend
rs.movenext
Wend
rs.close
wfile.close
Set fso = Nothing
Set conn = Nothing
Set com = Nothing
WScript.echo "Done"
Sub procmailboxes(servername,mailboxname)
Set objSession = CreateObject("MAPI.Session")
objSession.Logon "","",False,True,True,True,servername & vbLF & mailboxname
Set objInfoStores = objSession.InfoStores
Set objInfoStore = objSession.GetInfoStore
If objSession.outofoffice = True Then
Set Inbox = objSession.Inbox
If inbox.fields.item(PR_HAS_RULES) = True Then
Set objMessages = inbox.HiddenMessages
For Each objMessage In objMessages
If objMessage.type = "IPM.Rule.Message" Then
Call procrule(objMessage,mailboxname,inbox.fields.item(PR_URL_NAME).value)
End If
Next
End If
End If
End Sub
Sub procrule(objmessage,MailboxName,folderpath)
frule = False
splitarry = Split(hextotext(objmessage.fields.item(&H65EF0102)),Chr(132),-1,1)
If UBound(splitarry) <> 0 Then
WScript.echo
WScript.echo "Mailbox Name :" & MailboxName
WScript.echo "Folder Path :" & folderpath
WScript.echo "Rule Created By : " & objmessage.fields.item(PR_CREATOR).value
mbname = MailboxName
fpath = folderpath
creator = objmessage.fields.item(PR_CREATOR).value
frule = True
End If
tfirst = 0
addcount = 1
For i = 0 To UBound(splitarry)
addrrsplit = Split(splitarry(i),Chr(176),-1,1)
For j = 0 To UBound(addrrsplit)
addrcontsep = Chr(3) & "0"
If InStr(addrrsplit(j),addrcontsep) Then
If tfirst = 1 Then addcount = addcount + 1
WScript.echo
WScript.echo "Address Object :" & addcount
ReDim Preserve resarray(1,1,1,1,1,addcount)
resarray(1,0,0,0,0,addcount) = mbname
resarray(1,1,0,0,0,addcount) = fpath
resarray(1,1,1,0,0,addcount) = creator
If InStr(addrrsplit(j),"0/o=") Then
resarray(1,1,1,1,0,addcount) = Mid(addrrsplit(j),(InStr(addrrsplit(j),"0/o=")+1),Len(addrrsplit(j)))
WScript.echo "ExchangeDN :" & Mid(addrrsplit(j),(InStr(addrrsplit(j),"0/o=")+1),Len(addrrsplit(j)))
Else
WScript.echo "Address :" & Mid(addrrsplit(j),3,Len(addrrsplit(j)))
resarray(1,1,1,1,0,addcount) = Mid(addrrsplit(j),3,Len(addrrsplit(j)))
End If
tfirst = 1
End If
smtpsep = Chr(254) & "9"
If InStr(addrrsplit(j),smtpsep) Then
slen = InStr(addrrsplit(j),smtpsep) + 2
elen = InStr(addrrsplit(j),Chr(3))
WScript.echo "SMTP Forwarding Address : " & Mid(addrrsplit(j),slen,(elen-slen))
resarray(1,1,1,1,1,addcount) = Mid(addrrsplit(j),slen,(elen-slen))
End If
Next
Next
If frule = True Then
For r = 1 To UBound(resarray,6)
wfile.writeline("[" & resarray(1,0,0,0,0,r) & "]" & vbnewline & "Name=" & resarray(1,1,1,0,0,r) & vbnewline & "forwardto=" & resarray(1,1,1,1,1,r) & vbnewline & "creator=" & resarray(1,1,1,0,0,r))
Next
End If
End Sub
Function hextotext(binprop)
arrnum = Len(binprop)/2
ReDim aout(arrnum)
slen = 1
For i = 1 To arrnum
If CLng("&H" & Mid(binprop,slen,2)) <> 0 Then
aOut(i) = Chr(CLng("&H" & Mid(binprop,slen,2)))
rem wscript.echo CLng("&H" & mid(binprop,slen,2)) & "," & chr(CLng("&H" & mid(binprop,slen,2)))
End If
slen = slen+2
Next
hextotext = Join(aOUt,"")
End Function