|
johndeere -> RE: find public folder from email address (7.Oct.2010 1:54:16 AM)
|
I finally got a response back from Microsoft about this issue, and have since compiled this .vbs using their code as a base. Hopefully it'll help others who have Exchage 2003, and have the same issue. Works fine on XP workstation or Server 2003 (masking password part doesn't work on other OS's.
just save as .vbs file.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' A script to retrieve the full path of a public folder,
' from a supplied email address
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim strPublicFolderRoot, strFolderPath
Dim strDomain, sUserName, strPwd, strAddress, strServer, strOldString1, strOldString2, strNewString1, strNewString2
'Find %username% of user running script
Set objWSHShell = Wscript.CreateObject("Wscript.Shell")
sUserName = objWSHShell.ExpandEnvironmentStrings("%USERNAME%")
WScript.Echo "username: " & sUserName
'get user password
Do While Len(strPassword) = 0
strPassword = MaskPassword(FindOSType)
Wscript.Echo
Loop
'set Exchange Server to users local exchange server when running query
strServer = FindExchangeServer
'Wscript.Echo "Exchange Server: " & strServer
Do While Len(strAddress) = 0
Wscript.StdOut.Write "Please Type Public Folder SMTP address: "
strAddress = Wscript.StdIn.ReadLine
Loop
Wscript.Echo "Search can take a while (possibly 5-10 minutes) - please wait."
strPublicFolderRoot = "http://" & strServer & "/Public/"
strFolderPath = ""
'Search under root folder
DeepTravSearch(strPublicFolderRoot)
'Output the result
If( strFolderPath = "") Then
MsgBox "'" & strAddress & "' is not found under '" & strPublicFolderRoot & "'"
Else
'replace http://(exchange server name) with Public Folders - All Public Folders -
strOldString1 = "http://" & strServer & "/Public"
strOldString2 = "%20"
StrNewString1 = "Public Folders/All Public Folders"
StrNewString2 = " "
StrLocation = Replace(Replace(strFolderPath,strOldString1,StrNewString1),strOldString2,StrNewString2)
MsgBox "Public Folder Location is: " & (Chr(13)) & (Chr(13)) & (Chr(13)) & StrLocation,,"PUBLIC FOLDER LOCATION"
End If
Set sUserName = Nothing
Set strPassword = Nothing
Set strAddress = Nothing
Set strServer = Nothing
Set strReplaceString = Nothing
Set StrLocation = Nothing
'============================================================
'Find Operating System Version
'============================================================
Function FindOSType()
'Defining Variables
Dim objWMI, objItem, colItems
Dim OSVersion, OSName, ProductType
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
'Get the OS version number (first two) and OS product type (server or desktop)
For Each objItem in colItems
OSVersion = Left(objItem.Version,3)
ProductType = objItem.ProductType
Next
'Time to convert numbers into names
Select Case OSVersion
Case "6.0"
OSName = "Windows Vista"
Case "5.2"
OSName = "Windows 2003"
Case "5.1"
OSName = "Windows XP"
Case "5.0"
OSName = "Windows 2000"
Case "4.0"
OSName = "NT 4.0"
Case Else
OSName = "Windows ME or older"
End Select
'Return the OS name
FindOSType = OSName
'Wscript.Echo FindOSType
'Clear the memory
Set colItems = Nothing
Set objWMI = Nothing
End Function
'============================================================
'Find the local exchange server of user running script
'============================================================
Function FindExchangeServer()
Dim objWSHShell, objConnection, objCommand, objRootDSE, strDNSDomain
Dim strFilter, strQuery, objRecordSet, strSAM, strExchangeServer
Const adVarChar = 200
Const MaxCharacters = 255
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOOBject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
Set objRootDSE = GetObject("LDAP://RootDSE")
'Get domain
strDNSDomain = objRootDSE.Get("defaultNamingContext")
strBase = "<LDAP://" & strDNSDomain & ">"
'Define the filter elements
strFilter = "(&(objectCategory=person)(objectClass=user)(sAMAccountName=" & sUserName & "))"
'List all attributes you will require
strAttributes = "distinguishedName,homeMDB,sAMAccountName"
'compose query
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
objCommand.CommandText = strQuery
objCommand.Properties("Page Size") = 99999
objCommand.Properties("Timeout") = 300
objCommand.Properties("Cache Results") = False
Set objRecordSet = objCommand.Execute
If objRecordSet.EOF Then
wscript.echo sUserName & ": ** No Active Directory Account found **"
wscript.echo " "
End If
'if not at endoffile in recordset -ie record set is NOT empty - ie user found in AD
Do Until objRecordSet.EOF
strDN = objRecordSet.Fields("distinguishedName").Value
strSAM = objRecordSet.Fields("sAMAccountName")
strMDB = objRecordSet.Fields("homeMDB")
arrMailbox = Split(strMDB, ",")
strExchangeServer = mid(arrMailbox(3),(InStr(arrMailbox(3),"=")+1))
objRecordSet.MoveNext
Loop
FindExchangeServer = strExchangeServer
' Clean up.
objConnection.Close
Set objConnection = Nothing
Set objCommand = Nothing
Set objRootDSE = Nothing
Set objRecordSet = Nothing
Set strDNSDomain = Nothing
Set strFilter = Nothing
Set strQuery = Nothing
Set strSAM = Nothing
Set strExchangeServer = Nothing
Set sUserName = Nothing
End Function
'============================================================
' use ScriptPW (a COM object found only in Windows XP or Windows Server 2003) to mask passwords from the command line
'============================================================
Function MaskPassword(OS)
On Error Resume Next
If OS = "Windows XP" Then
'Msgbox "Operating System is" & FindOSType
Set objPassword = CreateObject("ScriptPW.Password")
WScript.StdOut.Write "Please enter your password:"
strResult = objPassword.GetPassword()
MaskPassword = strResult
ElseIf OS = "Windows 2003" Then
'Msgbox "Operating System is " & FindOSType
Set objPassword = CreateObject("ScriptPW.Password")
WScript.StdOut.Write "Please enter your password:"
strResult = objPassword.GetPassword()
MaskPassword = strResult
Else
wscript.echo "sorry, this only works on XP or 2003"
End If
End Function
'============================================================
'Manually traverse and serach the folder path under 'strRoot'
'============================================================
Function DeepTravSearch( strRoot)
Dim bRet
bRet = FindEqual(strRoot)
If( bRet = False) Then
Dim sRequest
sRequest = GetQuerySubFolders(strRoot)
'Open a Http Request
Dim objRequest
Set objRequest = CreateObject("Microsoft.xmlhttp")
objRequest.open "SEARCH", strRoot, false, sUserName, strPwd
'Set request headers
objRequest.setRequestHeader "Content-Type", "text/xml"
objRequest.setRequestHeader "Translate", "f"
objRequest.setRequestHeader "Depth", "0"
objRequest.setRequestHeader "Content-Length", Len(sRequest)
'Send the request
objRequest.send sRequest
'MsgBox objRequest.responseText
Dim xmlDoc
set xmlDoc=CreateObject("Microsoft.XMLDOM")
xmlDoc.async="false"
xmlDoc.loadXML(objRequest.responseText)
For Each node In xmlDoc.documentElement.childNodes
If Instr(node.xml,"<a:href>") <> 0 OR Instr(node.xml,"HTTP/1.1 200 OK") <> 0 Then
'Find the href which indicates the location and name of a message
index1 = InStrRev(node.xml,"<a:href>")
index2 = InStrRev(node.xml,"</a:href>")
value = Mid(node.xml,index1+8, index2-index1-8)
DeepTravSearch(value)
If(strFolderPath <> "") Then
' If have found the FolderPath, return back
Exit For
End If
End If
Next
End If
End Function
'============================================================
'Return a WebDav query which could compare the SMTP address the user input
'============================================================
Function GetQueryEqual( strRoot)
Dim query
query = "<?xml version=""1.0""?><g:searchrequest xmlns:g=""DAV:""><g:sql>SELECT ""DAV:href"" FROM SCOPE('HIERARCHICAL TRAVERSAL OF """ & strRootFolder & """') WHERE ""http://schemas.microsoft.com/exchange/publicfolderemailaddress"" = '" & strAddress & "' </g:sql></g:searchrequest>"
GetQueryEqual = query
End Function
'============================================================
'Return a WebDav query which could retrieve folder paths just under 'strRoot'
'============================================================
Function GetQuerySubFolders( strRoot)
Dim query
query = "<?xml version=""1.0""?><g:searchrequest xmlns:g=""DAV:""><g:sql>SELECT ""http://schemas.microsoft.com/exchange/publicfolderemailaddress"" FROM SCOPE('HIERARCHICAL TRAVERSAL OF """ & strRootFolder & """')</g:sql></g:searchrequest>"
GetQuerySubFolders = query
End Function
'============================================================
'Compare the SMTP address the user input with the address of the folders just under 'strRoot'
'============================================================
Function FindEqual( strRoot )
Dim sRequest
sRequest = GetQueryEqual(strRoot)
'Open a Http Request
Dim objRequest
Set objRequest = CreateObject("Microsoft.xmlhttp")
objRequest.open "SEARCH", strRoot, false, sUserName, strPwd
'Set request headers
objRequest.setRequestHeader "Content-Type", "text/xml"
objRequest.setRequestHeader "Translate", "f"
objRequest.setRequestHeader "Depth", "0"
objRequest.setRequestHeader "Content-Length", Len(sRequest)
'Send the request
objRequest.send sRequest
If Instr(objRequest.responseText,"<a:href>") <> 0 OR Instr(objRequest.responseText,"HTTP/1.1 200 OK") <> 0 Then
'Find the href which indicates the location and name of a message
index1 = InStrRev(objRequest.responseText,"<a:href>")
index2 = InStrRev(objRequest.responseText,"</a:href>")
value = Mid(objRequest.responseText,index1+8, index2-index1-8)
strFolderPath = value
'WScript.Echo "The item you are looking for is: " & sRetAddress
FindEqual = true
Else
'Not get the value
FindEqual = false
End If
End Function
|
|
|
|