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
|
|
|
|