• RSS
  • Twitter
  • FaceBook

Exchange Server Forums

Forums | Register | Login | My Profile | Inbox | RSS RSS icon | My Subscription | My Forums | Address Book | Member List | Search | FAQ | Ticket List | Log Out

find public folder from email address

Users viewing this topic: none

Logged in as: Guest
  Printable Version
All Forums >> [Microsoft Exchange 2003] >> Public Folders >> find public folder from email address Page: [1]
Login
Message << Older Topic   Newer Topic >>
find public folder from email address - 23.Sep.2010 3:07:12 AM   
johndeere

 

Posts: 2
Joined: 23.Sep.2010
Status: offline
we've got 1000's of Public Folders migrated from Exchange 5.5 to 2003 and we need a way to locate the full path to a public folder if only given the email address.

Custom Search in ADUC returns the name of the Public Folder that has that email associated with it, but not the path.
I'm trying to use a VB script to return the full path but the folderPath property is empty (migrated from 5.5) and scripts that transpose the GUID then don't return a valid result.

Can you help?
Post #: 1
RE: find public folder from email address - 7.Oct.2010 1:54:16 AM   
johndeere

 

Posts: 2
Joined: 23.Sep.2010
Status: offline
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

(in reply to johndeere)
Post #: 2

Page:   [1] << Older Topic    Newer Topic >>
All Forums >> [Microsoft Exchange 2003] >> Public Folders >> find public folder from email address Page: [1]
Jump to:

New Messages No New Messages
Hot Topic w/ New Messages Hot Topic w/o New Messages
Locked w/ New Messages Locked w/o New Messages
 Post New Thread
 Reply to Message
 Post New Poll
 Submit Vote
 Delete My Own Post
 Delete My Own Thread
 Rate Posts


Follow TechGenix on Twitter